Télécharger acctab.eso

Retour à la liste

Numérotation des lignes :

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

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