Sources Esope | Cast3M

ectab1
C ECTAB1    SOURCE    BP208322  21/04/15    21:15:01     10968          
 
************************************************************************
*     
*     OBJET :       Impression recursive d'une table
*     APPELEE PAR : ECTABL
*     Creation :    BP, 2016-09-12
*     
************************************************************************
 
      SUBROUTINE ECTAB1(ITAB1,NMAX)
 
 
*---- Declarations -----------------------------------------------------
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      EQUIVALENCE (IENT,REEL)
-INC PPARAM
-INC CCOPTIO
-INC SMTABLE
-INC CCNOYAU
-INC CCASSIS
      CHARACTER*8  ITYPE,ITYP
c       CHARACTER*20 IWRI,IWRV
      CHARACTER*(LOCHAI) IWRI
      CHARACTER*20 IWRV
      REAL*8  XR,XRET
      LOGICAL BRET
      PARAMETER(NI=10)
      INTEGER IDEB(NI),ITAB(NI)
      CHARACTER*(33) fm
      EXTERNAL           long
 
c   601 FORMAT( 2X,'.',1X,A,1X,'(=',A,')')
c   602 FORMAT( 4X,'.',1X,A,1X,'(=',A,')')
c   603 FORMAT( 6X,'.',1X,A,1X,'(=',A,')')
c   604 FORMAT( 8X,'.',1X,A,1X,'(=',A,')')
c   605 FORMAT(10X,'.',1X,A,1X,'(=',A,')')
c   606 FORMAT(12X,'.',1X,A,1X,'(=',A,')')
c   607 FORMAT(14X,'.',1X,A,1X,'(=',A,')')
c   608 FORMAT(16X,'.',1X,A,1X,'(=',A,')')
c   609 FORMAT(18X,'.',1X,A,1X,'(=',A,')')
c   610 FORMAT(20X,'.',1X,A,1X,'(=',A,')')
 
 
*---- Initialisations --------------------------------------------------
 
      IF(NMAX.GT.NI) THEN
c c       Nombre inacceptable %i1
c         INTERR(1)=NMAX
c         CALL ERREUR(36)
        WRITE(IOIMP,*) 'La profondeur est limitee a ',NI
        NMAX=NI
      ENDIF
 
      DO I=1,NI
        IDEB(I)=0
        ITAB(I)=0
      ENDDO
      IPROF=1
      ITAB(IPROF)=ITAB1
 
 
c---- boucle sur les profondeurs de la table ---------------------------
 
  100 CONTINUE
      MTABLE=ITAB(IPROF)
      SEGACT,MTABLE
      NB=MLOTAB
c       IF(IDEB(IPROF).EQ.0) THEN
c         WRITE(*,*) '#100 >>>>>>>> Niveau ',IPROF,MTABLE,NB
c       ENDIF
 
 
c---- boucle sur les indices -------------------------------------------
c     de la IPROF ieme table
 
  200 CONTINUE 
      IDEB(IPROF)=IDEB(IPROF)+1
      IJ=IDEB(IPROF)
c       WRITE(*,*) '#200      >>>>>>>>>>> Niveau, indice ',IPROF,IJ,NB
 
c     on a atteint le dernier indice
      IF(IJ.GT.NB) THEN
        SEGDES,MTABLE
        IPROF=IPROF-1
c       on a atteint le dernier niveau : on a fini
        IF(IPROF.EQ.0) RETURN
        GOTO 100
      ENDIF
 
c --- IJieme Indice --- --- --- ---
      ITYPE=MTABTI(IJ)
      IRET=MTABII(IJ)
      XRET=RMTABI(IJ)
      IWRI=' '
      IF(ITYPE.EQ.'MOT     '.OR.ITYPE.EQ.'METHODE ') THEN
        ID=IPCHAR(IRET)
        IFI=IPCHAR(IRET+1)
        IL=IFI-ID
        IL=MIN(IL,LOCHAI)
        IWRI(1:IL)=ICHARA(ID:ID+IL-1)
      ELSEIF(ITYPE.EQ.'ENTIER  ') THEN
        IV=IRET
c         WRITE(IWRI(1:8),FMT='(I8)') IV
c       bp : petite modif pour aligner a gauche les nombres
        IF(IV.LT.10) THEN 
          WRITE(IWRI(1:8),FMT='(I1)') IV
        ELSEIF(IV.LT.100) THEN
          WRITE(IWRI(1:8),FMT='(I2)') IV
        ELSEIF(IV.LT.1000) THEN
          WRITE(IWRI(1:8),FMT='(I3)') IV
        ELSEIF(IV.LT.10000) THEN
          WRITE(IWRI(1:8),FMT='(I4)') IV
        ELSEIF(IV.LT.100000) THEN
          WRITE(IWRI(1:8),FMT='(I5)') IV
        ELSEIF(IV.LT.1000000) THEN
          WRITE(IWRI(1:8),FMT='(I6)') IV
        ELSEIF(IV.LT.10000000) THEN
          WRITE(IWRI(1:8),FMT='(I7)') IV
        ELSE
          WRITE(IWRI(1:8),FMT='(I8)') IV
        ENDIF
      ELSEIF(ITYPE.EQ.'FLOTTANT') THEN
        XR=XRET
        WRITE(IWRI(1:15),FMT='(E15.8)') XR
      ELSEIF(ITYPE.EQ.'LOGIQUE')THEN
        BRET=IPLOGI(IRET)
        IF(BRET) IWRI(1:4)='VRAI'
        IF(.NOT.BRET) IWRI(1:4)='FAUX'
      ELSE
        WRITE(IWRI(1:8),FMT='(I8)') IRET
      ENDIF
 
*     on s'inspire de messag.eso
      fm(1:1)='('
      write(fm(2:3),fmt='(I2)') (2*IPROF)
      write(fm(4:10),fmt='(A7)') "X,'.',X"
      ifm=11
c     -> fm=( 2X,'.', X
      ilong=long(IWRI)
      if(ilong.ne.0) then
        write(fm(ifm:ifm+1),fmt='(A2)') ',A'
        ifm=ifm+2
        if (ilong.le.9) then
          write(fm(ifm:ifm),fmt='(i1)') ilong
          ifm=ifm+1
        elseif (ilong.le.99) then 
          write(fm(ifm:ifm+1),fmt='(i2)') ilong
          ifm=ifm+2
        elseif (ilong.le.999) then
          write(fm(ifm:ifm+2),fmt='(i3)') ilong
          ifm=ifm+3
        else
          call erreur(5)
          return
        endif
      endif    
c     -> fm=( 2X,'.', X,A1
c                        12
c                        123
 
c --- IJieme Valeur --- --- --- ---
      ITYP=MTABTV(IJ)
      IRET=MTABIV(IJ)
      XRET=RMTABV(IJ)
c       IWRV=' '
c       IF(ITYP.EQ.'MOT     ') THEN
c         ID=IPCHAR(IRET)
c         IFI=IPCHAR(IRET+1)
c         IL=IFI-ID
c         IL=MIN(IL,20)
c         IWRV(1:IL)=ICHARA(ID:ID+IL-1)
c       ELSEIF(ITYP.EQ.'ENTIER  ') THEN
c         IV=IRET
c         WRITE(IWRV(1:8),FMT='(I8)') IV
c       ELSEIF(ITYP.EQ.'FLOTTANT')THEN
c         XR=XRET
c         WRITE(IWRV(1:15),FMT='(E15.8)') XR
c       ELSEIF(ITYP.EQ.'LOGIQUE')THEN
c         BRET=IPLOGI(IRET)
c         IF(BRET) IWRV(1:4)='VRAI'
c         IF(.NOT.BRET) IWRV(1:4)='FAUX'
c       ELSE
c         WRITE(IWRV(1:8),FMT='(I8)') IRET
c       ENDIF
c       
c c     on ecrit la IJieme ligne : 
c       IF(IPROF.EQ.1)  WRITE(IOIMP,601) IWRI,ITYP,IWRV
c       IF(IPROF.EQ.2)  WRITE(IOIMP,602) IWRI,ITYP,IWRV
c       IF(IPROF.EQ.3)  WRITE(IOIMP,603) IWRI,ITYP,IWRV
c       IF(IPROF.EQ.4)  WRITE(IOIMP,604) IWRI,ITYP,IWRV
c       IF(IPROF.EQ.5)  WRITE(IOIMP,605) IWRI,ITYP,IWRV
c       IF(IPROF.EQ.6)  WRITE(IOIMP,606) IWRI,ITYP,IWRV
c       IF(IPROF.EQ.7)  WRITE(IOIMP,607) IWRI,ITYP,IWRV
c       IF(IPROF.EQ.8)  WRITE(IOIMP,608) IWRI,ITYP,IWRV
c       IF(IPROF.EQ.9)  WRITE(IOIMP,609) IWRI,ITYP,IWRV
c       IF(IPROF.EQ.10) WRITE(IOIMP,610) IWRI,ITYP,IWRV
 
*     bp: on ajuste le nombre d'espaces afin d'avoir tous les ITYP   
*         alignes pour des indices de longueur &lt; 25
*         pour les ITYP + grand, on prend 1 seul espace
      nbreX=max(30-(2*IPROF)-3-ilong,1)      
      write(fm(ifm:ifm+3),fmt='(A1,I2,A1)') ",",nbreX,"X"
      ifm=ifm+4
      write(fm(ifm:ifm+13),fmt='(A4,A8,A2)') ",'(=",ITYP,")'"
      ifm=ifm+14
      write(fm(ifm:ifm),fmt='(A1)') ')'
c       write(*,*) 'debug:',nbreX,' fm=',fm(1:ifm)
c     -> fm=( 2X,'.', X,A12,13X,'(=ITYP    )')
      WRITE(IOIMP,fmt=fm(1:ifm)) IWRI
 
c     Cas d'une TABLE : on l'explore si pas trop profond
      IF(ITYP.EQ.'TABLE') THEN
c       trop profond : on ne va pas plus loin
        IF(IPROF.GE.NMAX) THEN
c           WRITE(*,*) 'trop profond ! ',IPROF,' > ou = a',NMAX
          GOTO 200
        ENDIF
c       on change de table courante
        IPROF=IPROF+1
        ITAB(IPROF)=IRET
        IDEB(IPROF)=0
        GOTO 100
      ENDIF
 
      GOTO 200
c---- fin de boucle sur les indices ------------------------------------
 
 
      RETURN
      END