Télécharger erre.eso

Retour à la liste

Numérotation des lignes :

  1. C ERRE SOURCE JC220346 19/12/29 21:15:03 10439
  2. SUBROUTINE ERRE
  3. C_______________________________________________________________________
  4. C
  5. C OPERATEUR ERRE
  6. C --------------
  7. C
  8. C PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 02/91
  9. C
  10. C_______________________________________________________________________
  11. C
  12. IMPLICIT INTEGER(I-N)
  13. IMPLICIT REAL*8(A-H,O-Z)
  14. C
  15. -INC CCNOYAU
  16. -INC CCOPTIO
  17. -INC SMLREEL
  18. -INC SMLENTI
  19. -INC SMLMOTS
  20. -INC SMLCHPO
  21. C
  22. CHARACTER AUX*120
  23. CHARACTER CTYP*8
  24. CHARACTER*1000 CHERR(2),CHLU(2)
  25. CHARACTER*2000 CHLUS
  26. CHARACTER*1 CH1
  27. CHARACTER*11 DIGIT
  28. LOGICAL ZAVEC,BOOL
  29. SEGMENT,IPODEB(0),IPOFIN(0)
  30. DATA DIGIT/'1234567890:'/
  31.  
  32. EXTERNAL LONG
  33. C
  34. AUX=' '
  35. ZAVEC=.FALSE.
  36.  
  37. C ==========================
  38. C DECLENCHEMENT D'UNE ERREUR
  39. C ==========================
  40.  
  41. C SYNTAXE1 => on fournit un message que l'on affiche juste avant
  42. C de declencher l'erreur 308
  43. CALL LIRCHA(AUX,0,IRETOU)
  44. IF (IRETOU.EQ.0) GOTO 250
  45. CALL LENCHA(AUX,LAUX)
  46. ZAVEC=(AUX(1:LAUX).EQ.'AVEC')
  47. IF (ZAVEC) GOTO 250
  48. WRITE(IOIMP,11) AUX
  49. 11 FORMAT(/,(1X,A73))
  50. CALL ERREUR(308)
  51. RETURN
  52. C
  53. C SYNTAXE2 => on remplit MOTERR, INTERR, REAERR et BOOERR avant
  54. C de declencher une erreur quelconque de GIBI.ERREUR
  55. 250 CALL LIRENT (KENT,0,IRETOU)
  56. IF (IRETOU.EQ.0) GOTO 255
  57.  
  58. IF (ZAVEC) THEN
  59.  
  60. C -------------------------------------------------------------
  61. C EN PREAMBULE : ON VA REMPLIR IPODEB ET IPOFIN AVEC LES BORNES
  62. C (DANS MOTERR) DE CHACUN DES MOTIFS %m OU %M
  63. C -------------------------------------------------------------
  64.  
  65. C ON PLACE DANS CHLU(1) ET CHLU(2) LE CONTENU DU MESSAGE D'ERREUR
  66. CALL ERREU1(KENT,CHLU,NIVEAU,NBL)
  67. IF (IERR.NE.0) RETURN
  68. II=0
  69. CHLUS(1:1000)=CHLU(1)
  70. IF (NBL.EQ.1) THEN
  71. CHLUS(1001:2000)=' '
  72. ELSE
  73. CHLUS(1001:2000)=CHLU(2)
  74. ENDIF
  75. IIMAX=LONG(CHLUS)
  76. SEGINI,IPODEB,IPOFIN
  77.  
  78.  
  79. C BOUCLE 2501 => ON CHERCHE UN MOTIF %m OU %M
  80. 2501 II=II+1
  81. IF (II.GT.IIMAX) GOTO 2504
  82. CH1=CHLUS(II:II)
  83. IF (CH1.NE.'%') GOTO 2501
  84. II=II+1
  85. CH1=CHLUS(II:II)
  86. IF (CH1.NE.'m'.AND.CH1.NE.'M') GOTO 2501
  87. IPOS=0
  88. ICOM=0
  89.  
  90. C BOUCLE 2502 => ON CHERCHE LES BORNES DU MOTIF
  91. 2502 II=II+1
  92. CH1=CHLUS(II:II)
  93. IPO=INDEX(DIGIT,CH1)
  94. IF (IPO.GE.1.AND.IPO.LE.10) THEN
  95. IPOS=IPOS*10
  96. IF (IPO.LT.10) IPOS=IPOS+IPO
  97. ELSEIF (IPO.EQ.11) THEN
  98. IF (ICOM.EQ.0) THEN
  99. IF (IPOS.EQ.0) GOTO 2501
  100. IDEB=IPOS
  101. IPOS=0
  102. ICOM=1
  103. GOTO 2502
  104. ELSE
  105. GOTO 2503
  106. ENDIF
  107. ELSE
  108. IF (ICOM.EQ.0.OR.IPOS.EQ.0) GOTO 2501
  109. GOTO 2503
  110. ENDIF
  111. GOTO 2502
  112.  
  113. C ETIQUETTE 2503 => ON A BIEN LU DEUX NOMBRES ENTIERS NON NULS
  114. 2503 IFIN=IPOS
  115. CALL AJOU(IPODEB,IDEB)
  116. CALL AJOU(IPOFIN,IFIN)
  117. II=II-1
  118. GOTO 2501
  119. 2504 CONTINUE
  120. NBMOT=IPODEB(/1)
  121.  
  122.  
  123. C ----------------------------------------------------------
  124. C ON PEUT DESORMAIS REMPLIR MOTERR, INTERR, REAERR ET BOOERR
  125. C ----------------------------------------------------------
  126.  
  127. IMOT=0
  128. IENT=0
  129. IFLO=0
  130. ILOG=0
  131. MOTERR=' '
  132. 251 CALL QUETYP(CTYP,0,IRET)
  133. IF (IRET.EQ.0) GOTO 252
  134.  
  135. C MOT ---> MOTERR
  136. IF (CTYP.EQ.'MOT') THEN
  137. CALL LIRCHA(AUX,1,LCH)
  138. IF (IERR.NE.0) RETURN
  139. IF (IMOT.LT.NBMOT) THEN
  140. IMOT=IMOT+1
  141. IDEB=IPODEB(IMOT)
  142. IFIN=IPOFIN(IMOT)
  143. LON=MIN(IFIN-IDEB+1,LCH)
  144. MOTERR(IDEB:IFIN)=AUX(1:LON)
  145. ENDIF
  146.  
  147. C LISTMOTS ---> MOTERR
  148. ELSEIF (CTYP.EQ.'LISTMOTS') THEN
  149. CALL LIROBJ('LISTMOTS',IOB,1,IRET)
  150. IF (IERR.NE.0) RETURN
  151. MLMOT1=IOB
  152. SEGACT,MLMOT1
  153. JGN=MLMOT1.MOTS(/1)
  154. JGM=MLMOT1.MOTS(/2)
  155. DO K=1,JGM
  156. AUX=MLMOT1.MOTS(K)
  157. LCH=LONG(AUX)
  158. IF (IMOT.LT.NBMOT) THEN
  159. IMOT=IMOT+1
  160. IDEB=IPODEB(IMOT)
  161. IFIN=IPOFIN(IMOT)
  162. LON=MIN(IFIN-IDEB+1,LCH)
  163. MOTERR(IDEB:IFIN)=AUX(1:LON)
  164. ENDIF
  165. ENDDO
  166.  
  167. C ENTIER ---> INTERR
  168. ELSEIF (CTYP.EQ.'ENTIER') THEN
  169. CALL LIRENT(IVAL,1,IRET)
  170. IF (IERR.NE.0) RETURN
  171. IF (IENT.LT.9) THEN
  172. IENT=IENT+1
  173. INTERR(IENT)=IVAL
  174. ENDIF
  175.  
  176. C LISTENTI ---> INTERR
  177. ELSEIF (CTYP.EQ.'LISTENTI') THEN
  178. CALL LIROBJ('LISTENTI',IOB,1,IRET)
  179. IF (IERR.NE.0) RETURN
  180. MLENT1=IOB
  181. SEGACT,MLENT1
  182. JG=MLENT1.LECT(/1)
  183. DO K=1,JG
  184. IF (IENT.LT.9) THEN
  185. IENT=IENT+1
  186. INTERR(IENT)=MLENT1.LECT(K)
  187. ENDIF
  188. ENDDO
  189.  
  190. C FLOTTANT ---> REAERR
  191. ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  192. CALL LIRREE(XVAL,1,IRET)
  193. IF (IERR.NE.0) RETURN
  194. IF (IFLO.LT.9) THEN
  195. IFLO=IFLO+1
  196. REAERR(IFLO)=XVAL
  197. ENDIF
  198.  
  199. C LISTREEL ---> REAERR
  200. ELSEIF (CTYP.EQ.'LISTREEL') THEN
  201. CALL LIROBJ('LISTREEL',IOB,1,IRET)
  202. IF (IERR.NE.0) RETURN
  203. MLREE1=IOB
  204. SEGACT,MLREE1
  205. JG=MLREE1.PROG(/1)
  206. DO K=1,JG
  207. IF (IFLO.LE.9) THEN
  208. IFLO=IFLO+1
  209. REAERR(IFLO)=MLREE1.PROG(K)
  210. ENDIF
  211. ENDDO
  212.  
  213. C LOGIQUE ---> BOOERR
  214. ELSEIF (CTYP.EQ.'LOGIQUE') THEN
  215. CALL LIRLOG(BOOL,1,IRET)
  216. IF (IERR.NE.0) RETURN
  217. IF (ILOG.LT.9) THEN
  218. ILOG=ILOG+1
  219. BOOERR(ILOG)=BOOL
  220. ENDIF
  221.  
  222. C Objet de type incorrect
  223. ELSE
  224. MOTERR(1:8)=CTYP
  225. CALL ERREUR(39)
  226. RETURN
  227. ENDIF
  228.  
  229. GOTO 251
  230.  
  231. ENDIF
  232.  
  233. 252 IF (ICHA.EQ.0.AND.IENT.EQ.0.AND.IFLO.EQ.0.AND.ILOG.EQ.0) THEN
  234. MOTERR(1:4)='AVEC'
  235. CALL ERREUR(166)
  236. RETURN
  237. ENDIF
  238.  
  239. IF (ZAVEC) SEGSUP,IPODEB,IPOFIN
  240. CALL ERREUR(KENT)
  241. RETURN
  242.  
  243.  
  244. C ===============
  245. C CALCUL D'ERREUR
  246. C ===============
  247.  
  248. 255 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU)
  249. IF (IRETOU.EQ.0) GOTO 256
  250. CALL LIROBJ('CHPOINT ',IPO2,1,IRETOU)
  251. IF (IERR.NE.0) RETURN
  252. CALL ADCHPO(IPO1,IPO2,IRET,1D0,-1D0)
  253. IF (IRET.EQ.0) RETURN
  254. call ecrCHA('ABS')
  255. CALL ECROBJ('CHPOINT ',IRET)
  256. CALL MAXIMU(1)
  257. RETURN
  258.  
  259. 256 CALL LIROBJ('LISTCHPO',IPO1,0,IRETOU)
  260. IF (IRETOU.EQ.0) GOTO 260
  261. CALL LIROBJ('LISTCHPO',IPO2,1,IRETOU)
  262. IF (IERR.NE.0) RETURN
  263.  
  264. mlchp1 = ipo1
  265. mlchp2 = ipo2
  266. segact mlchp1, mlchp2
  267. if (mlchp1.ichpoi(/1).ne.mlchp2.ichpoi(/1)) call erreur(3)
  268. if (ierr.ne.0) return
  269. JG = mlchp1.ichpoi(/1)
  270. segini mlreel
  271. do ii = 1 ,jg
  272. ipo1 = mlchp1.ichpoi(ii)
  273. ipo2 = mlchp2.ichpoi(ii)
  274. CALL ADCHPO(IPO1,IPO2,IRET,1D0,-1D0)
  275. IF (IRET.EQ.0) RETURN
  276. call ecrCHA('ABS')
  277. CALL ECROBJ('CHPOINT ',IRET)
  278. CALL MAXIMU(1)
  279. call lirree(xx,1,iretou)
  280. if (ierr.ne.0) return
  281. prog(ii) = xx
  282. enddo
  283. call ECROBJ('LISTREEL',mlreel)
  284. RETURN
  285.  
  286. C_______________________________________________________________________
  287. C
  288. C CALCUL D'ERREUR ( VERSION BARZIC ET RICHARD )
  289. C_______________________________________________________________________
  290. C
  291. 260 CONTINUE
  292. CALL LIROBJ('MMODEL ',IPMODL,1,IRETM)
  293. CALL ACTOBJ('MMODEL ',IPMODL,1)
  294. IF (IERR.NE.0) RETURN
  295. C
  296. CALL LIROBJ('MCHAML',IPIN,1,IRETOU)
  297. CALL ACTOBJ('MCHAML',IPIN,1)
  298. IF (IERR.NE.0)RETURN
  299. CALL REDUAF(IPIN,IPMODL,IPCHE1,0,IR,KER)
  300. IF(IR .NE. 1) CALL ERREUR(KER)
  301. IF(IERR .NE. 0) RETURN
  302.  
  303. CALL LIROBJ('MCHAML',IPIN,1,IRETOU)
  304. CALL ACTOBJ('MCHAML',IPIN,1)
  305. IF (IERR.NE.0) RETURN
  306. CALL REDUAF(IPIN,IPMODL,IPCHE2,0,IR,KER)
  307. IF(IR .NE. 1) CALL ERREUR(KER)
  308. IF(IERR .NE. 0) RETURN
  309. C
  310. CALL RNGCHA (IPCHE1,IPCHE2,'CONTRAINTES','CARACTERISTIQUES'
  311. 1 ,IPCH1,IPCH2)
  312. IF(IPCH1.EQ.0.OR.IPCH2.EQ.0)THEN
  313. IF(IPCH1.EQ.0)THEN
  314. MOTERR(1:16)='CONTRAINTES '
  315. ELSE
  316. MOTERR(1:16)='CARACTERISTIQUES'
  317. ENDIF
  318. CALL ERREUR(565)
  319. RETURN
  320. ENDIF
  321. C
  322. CALL ERRARE(IPMODL,IPCH1,IPCH2,XERR,IPCHRR)
  323. C
  324. IF (IPCHRR.NE.0) THEN
  325. CALL ACTOBJ('MCHAML ',IPCHRR,1)
  326. CALL ECROBJ('MCHAML ',IPCHRR)
  327. CALL ECRREE(XERR)
  328. ENDIF
  329.  
  330. RETURN
  331. END
  332.  
  333.  
  334.  
  335.  
  336.  

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