Télécharger acctab.eso

Retour à la liste

Numérotation des lignes :

  1. C ACCTAB SOURCE PV 18/06/08 21:15:02 9841
  2. SUBROUTINE ACCTAB(MTABLE,TAPIND,IVALIN,XVALIN,CHARIN,LOGIN,IOBIN,
  3. $ TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IOBRE)
  4. C
  5. C **** DONNE ACCES A UN OBJET DANS UNE TABLE CONNAISSANT LE TYPE
  6. C **** DE L'INDICE ( TAPIND ) ET LA VALEUR DE L'INDICE SUIVANT SON
  7. C **** TYPE . ENTIER-IVAL;FLOTTANT-XVAL;MOT-CHARIN;LOGIQUE-LOGIN;
  8. C **** AUTRE-IOBIN
  9. C ON PEUT PRECISER LE TYPE D'OBJET ATTENDU DANS TYPOBJ CE
  10. C QUI PROVOQUE UN MESSAGE D'ERREUR S'IL N'EXISTE PAS.
  11. C **** EN SORTIE : TYPOBJ TYPE DE L'OBJET AU CAS OU TYPOBJ ETAIT = ' '
  12. C **** VALEUR DE L'OBJET DANS IVALRE SI ENTIER; XVALRE SI
  13. C **** FLOTTANT; CHARRE SI MOT ( DE LA LONGUEUR DE LA
  14. C **** CHAINE ENVOYEE EN ARGUMENT);LOGRE SI LOGIQUE;
  15. C **** IOBRE POUR TOUT AUTRE TYPE
  16. C
  17. IMPLICIT INTEGER(I-N)
  18. -INC CCNOYAU
  19. -INC CCOPTIO
  20. -INC SMTABLE
  21. -INC SMCOORD
  22. -INC CCASSIS
  23. external long
  24. CHARACTER*(*) TAPIND,TYPOBJ,CHARIN,CHARRE
  25. REAL*8 XVALIN,XVALRE
  26. LOGICAL LOGRE,LOGIN
  27. character*72 motass
  28. logical iloremp,lomisa,LOLO
  29. CHARACTER*(8) CHARA,TYPIND,CHARTP
  30. character*72 charic
  31.  
  32. nth=0
  33.  
  34. if (nbesc.ne.0) call ooonth(nth)
  35. call poscha(tapind,itypin)
  36. TYPIND=TAPIND
  37.  
  38. CHARA=TYPOBJ
  39. IOBRE=0
  40. IF(CHARA.EQ.' ') THEN
  41. IF(LEN(TYPOBJ).LT.8) THEN
  42. CALL ERREUR(5)
  43. RETURN
  44. ENDIF
  45. ENDIF
  46. SEGACT MTABLE
  47. segact ipiloc
  48. iesc=0
  49. if (mlotab.ge.1) then
  50. CHARTP=mtabtv(1)(1:8)
  51. if (CHARTP.eq.'MOT ') then
  52. IP=MTABIV(1)
  53. ID=IPCHAR(IP)
  54. IFI=IPCHAR(IP+1)
  55. CHARTP=ICHARA(ID:IFI-1)
  56. if (chartp.eq.'ESCLAVE ') iesc=1
  57. endif
  58. endif
  59. IN = MLOTAB
  60. IF(IN.EQ.0.AND.CHARA.NE.' ') GO TO 1000
  61.  
  62. IF(IN.EQ.0) then
  63. if(nbesc.ne.0) segdes ipiloc
  64. if (iesc.eq.0) segdes mtable
  65. RETURN
  66. endif
  67.  
  68. IF(TYPIND.EQ.'ENTIER ') then
  69. IA=1
  70. ELSEIF(TYPIND.EQ.'FLOTTANT') then
  71. IA=2
  72. ELSEIF(TYPIND.EQ.'MOT ') then
  73. IA=3
  74. ELSEIF(TYPIND.EQ.'LOGIQUE ') then
  75. IA=5
  76. ELSEIF(TYPIND.EQ.'METHODE ') then
  77. IA=3
  78. else
  79. IA=4
  80. endif
  81. IF(IA.EQ.3) THEN
  82. IL=LONG(CHARIN)
  83. CHARIC=CHARIN(1:il)
  84. call poscha(charic,ichari)
  85. endif
  86. DO 1 I=1,IN
  87. if (ia.eq.3) then
  88. if (mtabii(i).eq.ichari) then
  89. * ne pas mettre chartp our ne pas que l'optimiseur le sorte du test
  90. IF(mtabti(i)(1:8).NE.TYPIND ) GO TO 1
  91. goto 20
  92. endif
  93. endif
  94. chartp=mtabti(i)(1:8)
  95. IF(chartp.NE.TYPIND ) GO TO 1
  96. GO TO (11,12,13,14,15),IA
  97. 11 CONTINUE
  98. IF(MTABII(I).NE.IVALIN) GO TO 1
  99. GOTO 20
  100. 12 CONTINUE
  101. IF(RMTABI(I).NE.XVALIN ) GO TO 1
  102. GO TO 20
  103. 15 CONTINUE
  104. IF(IPLOGI(MTABII(I)).NEQV.LOGIN ) GO TO 1
  105. GO TO 20
  106. 14 CONTINUE
  107. IF(MTABII(I).NE.IOBIN) GO TO 1
  108. GOTO 20
  109. 13 CONTINUE
  110. 1 CONTINUE
  111.  
  112. C
  113. C ***** L'INDICE N'EXISTE PAS
  114. C
  115. 1000 IF(CHARA.NE.' ') THEN
  116. IF ( TYPIND.EQ.'FLOTTANT') THEN
  117. REAERR(1)= XVALIN
  118. CALL ERREUR ( 534)
  119. ELSEIF (TYPIND.EQ.'MOT ') THEN
  120. C WRITE(6,FMT='(A40)') CHARIN
  121. IOL=LEN(CHARIN)
  122. MOTERR=CHARIN
  123. IF(IOL.GT.8) MOTERR(9:11) = '...'
  124. CALL ERREUR (535)
  125. ELSE
  126. MOTERR(1:8) = TYPIND
  127. INTERR(1)= IOBIN
  128. IF(TYPIND.EQ.'ENTIER ') INTERR(1) = IVALIN
  129. CALL ERREUR (171)
  130. ENDIF
  131. C CALL ERREUR (314)
  132. C WRITE(6,FMT='('' INDICE EXISTE PAS '') ')
  133. C WRITE(6,FMT='('' TAPIND '',A8) ')TAPIND
  134. C WRITE(6,FMT='('' CHARIN '',A8) ')CHARIN
  135. C WRITE(6,FMT='('' CHARA '',A8) ')CHARA
  136. C WRITE(6,FMT='('' TYPIND '',A8) ')TYPIND
  137. ENDIF
  138.  
  139. if(nbesc.ne.0) segdes ipiloc
  140. if (iesc.eq.0) segdes mtable
  141. RETURN
  142.  
  143. C
  144. C ***** ON A TROUVE L'INDICE
  145. C
  146. 20 CONTINUE
  147. if(nbesc.ne.0) segdes ipiloc
  148. TYPIND =MTABTV(I)(1:8)
  149. C decodage des objets esclaves si necessaire
  150. if (typind.eq.'ESCLAVE ') then
  151. LOMISA = .FALSE.
  152. if (.not.lodesl.or.nth.ne.0) lomisa =.true.
  153. IF ( LOMISA ) THEN
  154. segdes mcoord
  155. mesres = mtabiv(i)
  156. SEGACT MESRES
  157. NESRES = IESRES
  158. segact nesres
  159.  
  160. if (.not.loremp) then
  161. 10 continue
  162. segdes nesres*record
  163. segdes mesres
  164. C segdes ipiloc
  165. SEGACT NESRES*(ECR=1,MOD)
  166. segact mesres
  167. if (.not.loremp) then
  168. write(6,*) ' loremp pas vrai dans acctab '
  169. goto 10
  170. endif
  171. endif
  172.  
  173. C segdes mesres
  174. segact mcoord
  175. C call tabesc(mtable,i,nesres)
  176. C segact mtable
  177. CHARA=esrety(1:8)
  178. TYPOBJ=CHARA
  179. IF (CHARA .EQ. 'LOGIQUE ') THEN
  180. LOGRE =esrelo
  181. ELSEIF (CHARA .EQ. 'ENTIER ') THEN
  182. IVALRE=esreva
  183. ELSEIF (CHARA .EQ. 'MOT ') THEN
  184. CHARRE=esrech(1:8)
  185. ELSEIF (CHARA .EQ. 'FLOTTANT') THEN
  186. XVALRE=esrere
  187. ELSE
  188. IOBRE =esreva
  189. ENDIF
  190. C segact MESRES*MOD
  191. segdes nesres,mesres
  192. if(nbesc.ne.0) segdes ipiloc
  193. return
  194. endif
  195. endif
  196. IF(CHARA.NE.' ') THEN
  197. IF(TYPIND.NE.CHARA) THEN
  198. IF(TYPIND.NE.'ENTIER '.OR.CHARA.NE.'FLOTTANT') THEN
  199. C L'INDICE EXISTE MAIS LE TYPE NE CORRESPOND PAS
  200. IOL=LEN(CHARIN)
  201. MOTERR=CHARIN
  202. IF(IOL.GT.8) MOTERR(9:11) = '...'
  203. MOTERR(12:20)=CHARA
  204. CALL ERREUR(627)
  205. RETURN
  206. ENDIF
  207. ENDIF
  208. ELSE
  209. TYPOBJ=TYPIND
  210. ENDIF
  211.  
  212. segact ipiloc
  213. IF(TYPIND.EQ.'ENTIER ') THEN
  214. IVALRE=MTABIV(I)
  215. IF(CHARA.EQ.'FLOTTANT' ) XVALRE=IVALRE
  216.  
  217. ELSEIF(TYPIND.EQ.'FLOTTANT') THEN
  218. XVALRE=RMTABV(I)
  219.  
  220. ELSEIF(TYPIND.EQ.'MOT ') THEN
  221. IP=MTABIV(I)
  222. ID=IPCHAR(IP)
  223. IFI=IPCHAR(IP+1)
  224. CHARRE=ICHARA(ID:IFI-1)
  225. IVALRE=MIN(LEN(CHARRE),IFI - ID )
  226.  
  227. ELSEIF(TYPIND.EQ.'LOGIQUE ') THEN
  228. LOGRE=IPLOGI(MTABIV(I))
  229.  
  230. ELSE
  231. IOBRE=MTABIV(I)
  232. ENDIF
  233.  
  234. if(nbesc.ne.0) segdes ipiloc
  235. if (iesc.eq.0) segdes mtable
  236. RETURN
  237. C1000 CONTINUE
  238. C WRITE(6,FMT='('' APRES 1000 '') ')
  239. C WRITE(6,FMT='('' TAPIND '',A8) ')TAPIND
  240. C WRITE(6,FMT='('' CHARIN '',A8) ')CHARIN
  241. C WRITE(6,FMT='('' CHARA '',A8) ')CHARA
  242. C WRITE(6,FMT='('' TYPIND '',A8) ')TYPIND
  243. C CALL ERREUR(314)
  244. C RETURN
  245. END
  246.  
  247.  
  248.  
  249.  

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