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