Télécharger acctab.eso

Retour à la liste

Numérotation des lignes :

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

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