Télécharger acctab.eso

Retour à la liste

Numérotation des lignes :

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

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