Télécharger ectab1.eso

Retour à la liste

Numérotation des lignes :

  1. C ECTAB1 SOURCE BP208322 16/09/13 13:11:44 9083
  2.  
  3. ************************************************************************
  4. *
  5. * OBJET : Impression recursive d'une table
  6. * APPELEE PAR : ECTABL
  7. * Creation : BP, 2016-09-12
  8. *
  9. ************************************************************************
  10.  
  11. SUBROUTINE ECTAB1(ITAB1,NMAX)
  12.  
  13.  
  14. *---- Declarations -----------------------------------------------------
  15.  
  16. IMPLICIT INTEGER(I-N)
  17. IMPLICIT REAL*8 (A-H,O-Z)
  18. EQUIVALENCE (IENT,REEL)
  19. -INC PPARAM
  20. -INC CCOPTIO
  21. -INC SMTABLE
  22. -INC CCNOYAU
  23. -INC CCASSIS
  24. CHARACTER*8 ITYPE,ITYP
  25. CHARACTER*20 IWRI,IWRV
  26. REAL*8 XR,XRET
  27. LOGICAL BRET
  28. PARAMETER(NI=10)
  29. INTEGER IDEB(NI),ITAB(NI)
  30.  
  31. 601 FORMAT(2X,'.',1X,A20,9X,': ',A8,2X,A20)
  32. 602 FORMAT(4X,'.',1X,A20,7X,': ',A8,2X,A20)
  33. 603 FORMAT(6X,'.',1X,A20,5X,': ',A8,2X,A20)
  34. 604 FORMAT(8X,'.',1X,A20,3X,': ',A8,2X,A20)
  35. 605 FORMAT(10X,'.',1X,A20,1X,': ',A8,2X,A20)
  36. 606 FORMAT(12X,'.',1X,A20,1X,': ',A8,2X,A20)
  37. 607 FORMAT(14X,'.',1X,A20,1X,': ',A8,2X,A20)
  38. 608 FORMAT(16X,'.',1X,A20,1X,': ',A8,2X,A20)
  39. 609 FORMAT(18X,'.',1X,A20,1X,': ',A8,2X,A20)
  40. 610 FORMAT(20X,'.',1X,A20,1X,': ',A8,2X,A20)
  41.  
  42.  
  43. *---- Initialisations --------------------------------------------------
  44.  
  45. IF(NMAX.GT.NI) THEN
  46. c c Nombre inacceptable %i1
  47. c INTERR(1)=NMAX
  48. c CALL ERREUR(36)
  49. WRITE(IOIMP,*) 'La profondeur est limitee a ',NI
  50. NMAX=NI
  51. ENDIF
  52.  
  53. DO I=1,NI
  54. IDEB(I)=0
  55. ITAB(I)=0
  56. ENDDO
  57. IPROF=1
  58. ITAB(IPROF)=ITAB1
  59.  
  60.  
  61. c---- boucle sur les profondeurs de la table ---------------------------
  62.  
  63. 100 CONTINUE
  64. MTABLE=ITAB(IPROF)
  65. SEGACT,MTABLE
  66. NB=MLOTAB
  67. c IF(IDEB(IPROF).EQ.0) THEN
  68. c WRITE(*,*) '#100 >>>>>>>> Niveau ',IPROF,MTABLE,NB
  69. c ENDIF
  70.  
  71.  
  72. c---- boucle sur les indices -------------------------------------------
  73. c de la IPROF ieme table
  74.  
  75. 200 CONTINUE
  76. IDEB(IPROF)=IDEB(IPROF)+1
  77. IJ=IDEB(IPROF)
  78. c WRITE(*,*) '#200 >>>>>>>>>>> Niveau, indice ',IPROF,IJ,NB
  79.  
  80. c on a atteint le dernier indice
  81. IF(IJ.GT.NB) THEN
  82. SEGDES,MTABLE
  83. IPROF=IPROF-1
  84. c on a atteint le dernier niveau : on a fini
  85. IF(IPROF.EQ.0) RETURN
  86. GOTO 100
  87. ENDIF
  88.  
  89. c IJieme Indice
  90. ITYPE=MTABTI(IJ)
  91. IRET=MTABII(IJ)
  92. XRET=RMTABI(IJ)
  93. IWRI=' '
  94. IF(ITYPE.EQ.'MOT '.OR.ITYPE.EQ.'METHODE ') THEN
  95. ID=IPCHAR(IRET)
  96. IFI=IPCHAR(IRET+1)
  97. IL=IFI-ID
  98. IL=MIN(IL,20)
  99. IWRI(1:IL)=ICHARA(ID:ID+IL-1)
  100. ELSEIF(ITYPE.EQ.'ENTIER ') THEN
  101. IV=IRET
  102. c WRITE(IWRI(1:8),FMT='(I8)') IV
  103. c bp : petite modif pour aligner a gauche les nombres
  104. IF(IV.LT.10) THEN
  105. WRITE(IWRI(1:8),FMT='(I1)') IV
  106. ELSEIF(IV.LT.100) THEN
  107. WRITE(IWRI(1:8),FMT='(I2)') IV
  108. ELSEIF(IV.LT.1000) THEN
  109. WRITE(IWRI(1:8),FMT='(I3)') IV
  110. ELSEIF(IV.LT.10000) THEN
  111. WRITE(IWRI(1:8),FMT='(I4)') IV
  112. ELSEIF(IV.LT.100000) THEN
  113. WRITE(IWRI(1:8),FMT='(I5)') IV
  114. ELSEIF(IV.LT.1000000) THEN
  115. WRITE(IWRI(1:8),FMT='(I6)') IV
  116. ELSEIF(IV.LT.10000000) THEN
  117. WRITE(IWRI(1:8),FMT='(I7)') IV
  118. ELSE
  119. WRITE(IWRI(1:8),FMT='(I8)') IV
  120. ENDIF
  121. ELSEIF(ITYPE.EQ.'FLOTTANT') THEN
  122. XR=XRET
  123. WRITE(IWRI(1:15),FMT='(E15.8)') XR
  124. ELSEIF(ITYPE.EQ.'LOGIQUE')THEN
  125. BRET=IPLOGI(IRET)
  126. IF(BRET) IWRI(1:4)='VRAI'
  127. IF(.NOT.BRET) IWRI(1:4)='FAUX'
  128. ELSE
  129. WRITE(IWRI(1:8),FMT='(I8)') IRET
  130. ENDIF
  131.  
  132. c IJieme Valeur
  133. ITYP=MTABTV(IJ)
  134. IRET=MTABIV(IJ)
  135. XRET=RMTABV(IJ)
  136. IWRV=' '
  137. IF(ITYP.EQ.'MOT ') THEN
  138. ID=IPCHAR(IRET)
  139. IFI=IPCHAR(IRET+1)
  140. IL=IFI-ID
  141. IL=MIN(IL,20)
  142. IWRV(1:IL)=ICHARA(ID:ID+IL-1)
  143. ELSEIF(ITYP.EQ.'ENTIER ') THEN
  144. IV=IRET
  145. WRITE(IWRV(1:8),FMT='(I8)') IV
  146. ELSEIF(ITYP.EQ.'FLOTTANT')THEN
  147. XR=XRET
  148. WRITE(IWRV(1:15),FMT='(E15.8)') XR
  149. ELSEIF(ITYP.EQ.'LOGIQUE')THEN
  150. BRET=IPLOGI(IRET)
  151. IF(BRET) IWRV(1:4)='VRAI'
  152. IF(.NOT.BRET) IWRV(1:4)='FAUX'
  153. ELSE
  154. WRITE(IWRV(1:8),FMT='(I8)') IRET
  155. ENDIF
  156.  
  157. c on ecrit la IJieme ligne :
  158. IF(IPROF.EQ.1) WRITE(IOIMP,601) IWRI,ITYP,IWRV
  159. IF(IPROF.EQ.2) WRITE(IOIMP,602) IWRI,ITYP,IWRV
  160. IF(IPROF.EQ.3) WRITE(IOIMP,603) IWRI,ITYP,IWRV
  161. IF(IPROF.EQ.4) WRITE(IOIMP,604) IWRI,ITYP,IWRV
  162. IF(IPROF.EQ.5) WRITE(IOIMP,605) IWRI,ITYP,IWRV
  163. IF(IPROF.EQ.6) WRITE(IOIMP,606) IWRI,ITYP,IWRV
  164. IF(IPROF.EQ.7) WRITE(IOIMP,607) IWRI,ITYP,IWRV
  165. IF(IPROF.EQ.8) WRITE(IOIMP,608) IWRI,ITYP,IWRV
  166. IF(IPROF.EQ.9) WRITE(IOIMP,609) IWRI,ITYP,IWRV
  167. IF(IPROF.EQ.10) WRITE(IOIMP,610) IWRI,ITYP,IWRV
  168.  
  169. c Cas D'une TABLE : on l'explore si pas trop profond
  170. IF(ITYP.EQ.'TABLE') THEN
  171. c trop profond : on ne va pas plus loin
  172. IF(IPROF.GE.NMAX) THEN
  173. c WRITE(*,*) 'trop profond ! ',IPROF,' > ou = a',NMAX
  174. GOTO 200
  175. ENDIF
  176. c on change de table courante
  177. IPROF=IPROF+1
  178. ITAB(IPROF)=IRET
  179. IDEB(IPROF)=0
  180. GOTO 100
  181. ENDIF
  182.  
  183. GOTO 200
  184. c---- fin de boucle sur les indices ------------------------------------
  185.  
  186.  
  187. RETURN
  188. END
  189.  
  190.  

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