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

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