Sources Esope | Cast3M

acctab
C ACCTAB    SOURCE    PV        20/04/03    21:15:02     10571          
      SUBROUTINE ACCTAB(MTABLE,TAPIND,IVALIN,XVALIN,CHARIN,LOGIN,IOBIN,
     $                         TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IOBRE)
C
C  ****  DONNE ACCES A UN OBJET DANS UNE TABLE CONNAISSANT LE TYPE
C  ****  DE L'INDICE ( TAPIND ) ET LA VALEUR DE L'INDICE SUIVANT SON
C  ****  TYPE . ENTIER-IVAL;FLOTTANT-XVAL;MOT-CHARIN;LOGIQUE-LOGIN;
C  ****  AUTRE-IOBIN
C        ON PEUT PRECISER LE TYPE D'OBJET ATTENDU DANS TYPOBJ CE
C        QUI PROVOQUE UN MESSAGE D'ERREUR S'IL N'EXISTE PAS.
C  **** EN SORTIE : TYPOBJ TYPE DE L'OBJET AU CAS OU TYPOBJ ETAIT = ' '
C  ****             VALEUR DE L'OBJET DANS IVALRE SI ENTIER; XVALRE SI
C  ****             FLOTTANT; CHARRE SI MOT ( DE LA LONGUEUR DE LA
C  ****             CHAINE ENVOYEE EN ARGUMENT);LOGRE SI LOGIQUE;
C  ****             IOBRE POUR TOUT AUTRE TYPE
C
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCNOYAU
-INC CCOPTIO
-INC SMTABLE
-INC SMCOORD
-INC CCASSIS
 
      external long
      CHARACTER*(*) TAPIND,TYPOBJ,CHARIN,CHARRE
      REAL*8 XVALIN,XVALRE
      LOGICAL LOGRE,LOGIN
C       character*72 motass
      logical iloremp,lomisa,LOLO
      CHARACTER*(8) CHARA,TYPIND,CHARTP
      character*(LOCHAI) charic
 
      nth=0
      ith=oothrd
 
      if (nbesc.ne.0) nth=oothrd
      call poscha(tapind,itypin) 
      TYPIND=TAPIND
      CHARA=TYPOBJ
      IOBRE=0
      IF(CHARA.EQ.'        ') THEN
         IF(LEN(TYPOBJ).LT.8) THEN
         CALL ERREUR(5)
        if (iesc.eq.0.or.ith.ne.0) segdes mtable
         RETURN
         ENDIF
      ENDIF
      SEGACT MTABLE
      if(nbesc.ne.0) segact ipiloc
      iesc=0
          if (mlotab.ge.1) then
          if (mtabtv(1)(1:8).eq.'MOT     ') then
           IP=MTABIV(1)
           ID=IPCHAR(IP)
           IFI=IPCHAR(IP+1)
           CHARTP=ICHARA(ID:IFI-1)
           if (chartp.eq.'ESCLAVE ') iesc=1
          endif
          endif
      IN = MLOTAB
      IF(IN.EQ.0.AND.CHARA.NE.'        ') GO TO 1000
 
      IF(IN.EQ.0) then
        if(nbesc.ne.0) SEGDES,IPILOC
        if (iesc.eq.0.or.ith.ne.0) segdes mtable
        RETURN
      endif
 
      IF    (TYPIND.EQ.'ENTIER  ') then
       IA=1
      ELSEIF(TYPIND.EQ.'FLOTTANT') then
       IA=2
      ELSEIF(TYPIND.EQ.'MOT     ') then
       IA=3
      ELSEIF(TYPIND.EQ.'LOGIQUE ') then
       IA=5
      ELSEIF(TYPIND.EQ.'METHODE ') then
       IA=3
      else
       IA=4                          
      endif
      IF(IA.EQ.3) THEN
       IL=LONG(CHARIN)
       CHARIC=CHARIN(1:il)
       call poscha(charic,ichari)
      endif
      DO 1 I=1,IN
      if (ia.eq.3) then
        if (mtabii(i).eq.ichari) then
*  ne pas mettre chartp our ne pas que l'optimiseur le sorte du test
          IF(mtabti(i)(1:8).NE.TYPIND ) GO TO 1
          goto 20
        endif
      endif
      chartp=mtabti(i)(1:8)
      IF(chartp.NE.TYPIND ) GO TO 1
       GO TO (11,12,13,14,15),IA
   11 CONTINUE
        IF(MTABII(I).NE.IVALIN) GO TO 1
        GOTO 20
   12 CONTINUE
        IF(RMTABI(I).NE.XVALIN ) GO TO 1
        GO TO 20
   15 CONTINUE
        if(nbesc.ne.0) segact ipiloc
        IF(IPLOGI(MTABII(I)).NEQV.LOGIN ) GO TO 1
        GO TO 20
   14 CONTINUE
        IF(MTABII(I).NE.IOBIN)  GO TO 1
        GOTO 20
   13 CONTINUE
   1  CONTINUE
 
C
C *****   L'INDICE N'EXISTE PAS
C
1000  IF(CHARA.NE.'        ') THEN
        IF ( TYPIND.EQ.'FLOTTANT') THEN
           REAERR(1)= XVALIN
           CALL ERREUR ( 534)
        ELSEIF (TYPIND.EQ.'MOT     ') THEN
C          WRITE(6,FMT='(A40)') CHARIN
           IOL=LEN(CHARIN)
           MOTERR=CHARIN
           IF(IOL.GT.8) MOTERR(9:11) = '...'
           CALL ERREUR (535)
        ELSE
           MOTERR(1:8) = TYPIND
           INTERR(1)= IOBIN
           IF(TYPIND.EQ.'ENTIER  ') INTERR(1) = IVALIN
           CALL ERREUR (171)
        ENDIF
C       CALL ERREUR  (314)
C       WRITE(6,FMT='('' INDICE EXISTE PAS '') ')
C       WRITE(6,FMT='('' TAPIND '',A8) ')TAPIND
C       WRITE(6,FMT='('' CHARIN '',A8) ')CHARIN
C       WRITE(6,FMT='('' CHARA  '',A8) ')CHARA
C       WRITE(6,FMT='('' TYPIND '',A8) ')TYPIND
      ENDIF
 
      if(nbesc.ne.0) SEGDES,IPILOC
      if (iesc.eq.0..or.ith.ne.0) segdes mtable
      RETURN
 
C
C *****  ON A TROUVE L'INDICE
C
  20  CONTINUE
      if(nbesc.ne.0) SEGDES,IPILOC
      TYPIND =MTABTV(I)(1:8)
C decodage des objets esclaves si necessaire
      if (typind.eq.'ESCLAVE ') then
        LOMISA = .FALSE.
        if (.not.lodesl.or.nth.ne.0) lomisa    =.true.
        IF ( LOMISA ) THEN
          call oooeta(mcoord,ieta,imod)
          if (ieta.eq.1) segdes mcoord
          mesres = mtabiv(i)
          SEGACT MESRES
 
          if (.not.loremp) then
  10        continue
            segdes mesres*record
            SEGACT MESRES*(ECR=1,MOD)
            if (.not.loremp) then
              write(6,*) ' loremp pas vrai dans acctab '
              goto 10
            endif
          endif
 
          if (ieta.eq.1)segact mcoord
C          call tabesc(mtable,i,mesres)
C          segact mtable
          TYPOBJ=esrety
          IF     (TYPOBJ(1:8) .EQ. 'LOGIQUE ') THEN
            LOGRE =esrelo
          ELSEIF (TYPOBJ(1:8) .EQ. 'ENTIER  ') THEN
            IVALRE=esreva
          ELSEIF (TYPOBJ(1:8) .EQ. 'MOT     ') THEN
            CHARRE=esrech
          ELSEIF (TYPOBJ(1:8) .EQ. 'FLOTTANT') THEN
            XVALRE=esrere
          ELSE
            IOBRE =esreva
          ENDIF
          segdes mesres
          if(nbesc.ne.0) SEGDES,IPILOC
        if (iesc.eq.0.or.ith.ne.0) segdes mtable
          return
        endif
      endif
      IF(CHARA.NE.'        ') THEN
         IF(TYPIND.NE.CHARA) THEN
             IF(TYPIND.NE.'ENTIER  '.OR.CHARA.NE.'FLOTTANT') THEN
C              L'INDICE EXISTE MAIS LE TYPE NE CORRESPOND PAS
               IOL=LEN(CHARIN)
               MOTERR=CHARIN
               IF(IOL.GT.8) MOTERR(9:11) = '...'
               MOTERR(12:20)=CHARA
               CALL ERREUR(627)
        if (iesc.eq.0.or.ith.ne.0) segdes mtable
               RETURN
             ENDIF
          ENDIF
      ELSE
          TYPOBJ=TYPIND
      ENDIF
 
      if(nbesc.ne.0) segact ipiloc
      IF(TYPIND.EQ.'ENTIER  ') THEN
        IVALRE=MTABIV(I)
        IF(CHARA.EQ.'FLOTTANT' ) XVALRE=IVALRE
 
      ELSEIF(TYPIND.EQ.'FLOTTANT') THEN
        XVALRE=RMTABV(I)
 
      ELSEIF(TYPIND.EQ.'MOT     ') THEN
        IP=MTABIV(I)
        ID=IPCHAR(IP)
        IFI=IPCHAR(IP+1)
        CHARRE=ICHARA(ID:IFI-1)
        IVALRE=MIN(LEN(CHARRE),IFI - ID )
 
      ELSEIF(TYPIND.EQ.'LOGIQUE ') THEN
        LOGRE=IPLOGI(MTABIV(I))
 
      ELSE
        IOBRE=MTABIV(I)
      ENDIF
 
      if(nbesc.ne.0) SEGDES,IPILOC
      if (iesc.eq.0.or.ith.ne.0) segdes mtable
      RETURN
C1000 CONTINUE
C     WRITE(6,FMT='('' APRES   1000 '') ')
C     WRITE(6,FMT='('' TAPIND '',A8) ')TAPIND
C     WRITE(6,FMT='('' CHARIN '',A8) ')CHARIN
C     WRITE(6,FMT='('' CHARA  '',A8) ')CHARA
C     WRITE(6,FMT='('' TYPIND '',A8) ')TYPIND
C     CALL ERREUR(314)
C     RETURN
      END