Télécharger acctab.eso

Retour à la liste

Numérotation des lignes :

  1. C ACCTAB SOURCE PV 19/10/17 21:15:06 10339
  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.  
  157. if (.not.loremp) then
  158. 10 continue
  159. segdes mesres*record
  160. SEGACT MESRES*(ECR=1,MOD)
  161. if (.not.loremp) then
  162. write(6,*) ' loremp pas vrai dans acctab '
  163. goto 10
  164. endif
  165. endif
  166.  
  167. segact mcoord
  168. C call tabesc(mtable,i,mesres)
  169. C segact mtable
  170. TYPOBJ=esrety
  171. IF (TYPOBJ(1:8) .EQ. 'LOGIQUE ') THEN
  172. LOGRE =esrelo
  173. ELSEIF (TYPOBJ(1:8) .EQ. 'ENTIER ') THEN
  174. IVALRE=esreva
  175. ELSEIF (TYPOBJ(1:8) .EQ. 'MOT ') THEN
  176. CHARRE=esrech
  177. ELSEIF (TYPOBJ(1:8) .EQ. 'FLOTTANT') THEN
  178. XVALRE=esrere
  179. ELSE
  180. IOBRE =esreva
  181. ENDIF
  182. segdes mesres
  183. if(nbesc.ne.0) SEGDES,IPILOC
  184. return
  185. endif
  186. endif
  187. IF(CHARA.NE.' ') THEN
  188. IF(TYPIND.NE.CHARA) THEN
  189. IF(TYPIND.NE.'ENTIER '.OR.CHARA.NE.'FLOTTANT') THEN
  190. C L'INDICE EXISTE MAIS LE TYPE NE CORRESPOND PAS
  191. IOL=LEN(CHARIN)
  192. MOTERR=CHARIN
  193. IF(IOL.GT.8) MOTERR(9:11) = '...'
  194. MOTERR(12:20)=CHARA
  195. CALL ERREUR(627)
  196. RETURN
  197. ENDIF
  198. ENDIF
  199. ELSE
  200. TYPOBJ=TYPIND
  201. ENDIF
  202.  
  203. if(nbesc.ne.0) segact ipiloc
  204. IF(TYPIND.EQ.'ENTIER ') THEN
  205. IVALRE=MTABIV(I)
  206. IF(CHARA.EQ.'FLOTTANT' ) XVALRE=IVALRE
  207.  
  208. ELSEIF(TYPIND.EQ.'FLOTTANT') THEN
  209. XVALRE=RMTABV(I)
  210.  
  211. ELSEIF(TYPIND.EQ.'MOT ') THEN
  212. IP=MTABIV(I)
  213. ID=IPCHAR(IP)
  214. IFI=IPCHAR(IP+1)
  215. CHARRE=ICHARA(ID:IFI-1)
  216. IVALRE=MIN(LEN(CHARRE),IFI - ID )
  217.  
  218. ELSEIF(TYPIND.EQ.'LOGIQUE ') THEN
  219. LOGRE=IPLOGI(MTABIV(I))
  220.  
  221. ELSE
  222. IOBRE=MTABIV(I)
  223. ENDIF
  224.  
  225. if(nbesc.ne.0) SEGDES,IPILOC
  226. if (iesc.eq.0) segdes mtable
  227. RETURN
  228. C1000 CONTINUE
  229. C WRITE(6,FMT='('' APRES 1000 '') ')
  230. C WRITE(6,FMT='('' TAPIND '',A8) ')TAPIND
  231. C WRITE(6,FMT='('' CHARIN '',A8) ')CHARIN
  232. C WRITE(6,FMT='('' CHARA '',A8) ')CHARA
  233. C WRITE(6,FMT='('' TYPIND '',A8) ')TYPIND
  234. C CALL ERREUR(314)
  235. C RETURN
  236. END
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  

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