Télécharger verita.eso

Retour à la liste

Numérotation des lignes :

  1. C VERITA SOURCE CHAT 06/03/29 21:37:02 5360
  2. SUBROUTINE VERITA(ITABO,IPX,ICHA,ITOUS, ILEX,ITYPE)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C=======================================================================
  6. C POUR OPERATEUR EVOL SOLU "TABLE"
  7. C VERIFIE LA COMPATIBILITE DU CONTENU DE LA TABLE ET DU LISTREEL IPX
  8. C RETOUR :DANS ILEX UN SEGMENT MLENTI QUI CONTIENT LA LISTE DES CHAMPS
  9. C A PRENDRE.
  10. C :ITYPE ='TEMPS '
  11. C CREATION : 24/08/89
  12. C PROGRAMMEUR : LENA
  13. C=======================================================================
  14. CHARACTER*8 ITYPE,ICHA2,MOMO,MOE,MOT,CHARRE
  15. CHARACTER*15 ICHAI
  16. CHARACTER*4 MCHA
  17. LOGICAL L0,L1
  18. -INC CCOPTIO
  19. -INC SMELEME
  20. -INC SMTABLE
  21. -INC SMLENTI
  22. -INC SMSOLUT
  23. -INC SMLREEL
  24. DATA MOT /'MOT '/
  25. DATA MOE /'ENTIER '/
  26. DATA ICHAI /'TEMPS_DE_SORTIE'/
  27. C======================================================================
  28. C SI ITOUS=0, ON DOIT AVOIR UN IPX EN DONNEE
  29. IF(IPX.EQ.0.AND.ITOUS.EQ.0) THEN
  30. MOTERR(1:8)='LISTREEL'
  31. CALL ERREUR(37)
  32. GOTO 5000
  33. ENDIF
  34. C --- ON RECUPERE LE POINTEUR SUR LA LISTE DES PAS DE SORTIE
  35. LBO=0
  36. CALL ACCTAB(ITABO,MOT,I0,X0,ICHAI,L0,IRET0,
  37. 1 'LISTREEL',I1,X1,ICHA2,L1,LBO)
  38. MLREEL=LBO
  39. SEGACT MLREEL
  40. LTE =PROG(/1)
  41. SEGDES MLREEL
  42. IDEPAR=0
  43. * CALL ECROBJ('TABLE',ITABO)
  44. * CALL INDETA
  45. * CALL LIROBJ('TABLE',ITABIN,1,IRETAB)
  46. * IF (IERR.NE.0) RETURN
  47. *
  48. * Boucle sur les indices de la table MTABLE:
  49. *
  50. * MTABLE=ITABIN
  51. MTABLE=ITABO
  52. SEGACT MTABLE
  53. NINDIC = MLOTAB
  54. DO 100 INDICE = 1 , NINDIC
  55. I0= INDICE
  56. * MOMO =MOE
  57. * CALL ACCTAB(ITABIN,'ENTIER ',I0,X0,' ',L0,IRET0,
  58. * * MOMO ,I1,X1,CHARRE,L1,IRET1)
  59. * IF (MOMO .EQ.MOE) THEN
  60. IF ( MTABTI(INDICE).EQ.MOE) THEN
  61. IDEPAR=INDICE
  62. GO TO 110
  63. ENDIF
  64. 100 CONTINUE
  65. 110 SEGDES MTABLE
  66.  
  67. C-----------------------------
  68. IF (ITOUS.EQ.1) GO TO 10
  69. C-----------------------------
  70. C------ON NE PREND PAS TOUS LES PAS
  71. C **** ON VERIFIE D'ABORD QUE LA SUITE IPX EST CROISSANTE
  72. C
  73. IF(IPX.NE.0) THEN
  74. MLREE1=IPX
  75. SEGACT MLREE1
  76. LCAS=MLREE1.PROG(/1)
  77. DO 161 I=2,LCAS
  78. IF(MLREE1.PROG(I).GT.MLREE1.PROG(I-1)) GOTO 161
  79. CALL ERREUR(249)
  80. C LA SUITE DE REELS DOIT ETRE CROISSANTE
  81. GOTO 5000
  82. 161 CONTINUE
  83. ENDIF
  84. C--- ON VA CREER LA TABLE DES INDICES A PRENDRE
  85. JG=LCAS
  86. SEGINI MLENTI
  87. C
  88. MLREEL=LBO
  89. SEGACT MLREEL
  90. LTE =PROG(/1)
  91. PRECI = (PROG(LTE)-PROG(1))/(LTE*100)
  92. * PRECI = 1.E-3
  93. ITOS=1
  94. DO 152 KJ=1,LCAS
  95. TSEAR = MLREE1.PROG(KJ)
  96. CALL PLACE3 (PROG,ITOS,LTE,TSEAR,IPOS,AR)
  97. IF (AR.LE.PRECI) THEN
  98. GO TO 149
  99. ELSE
  100. RAR=ABS(1.-AR)
  101. IF (RAR.LE.PRECI) THEN
  102. IPOS=IPOS+1
  103. GO TO 149
  104. ELSE
  105. MOTERR(1:8) = 'TABLE '
  106. MOTERR(9:16) ='LISTREEL'
  107. CALL ERREUR(135)
  108. GO TO 5000
  109. ENDIF
  110. ENDIF
  111. 149 LECT(KJ) = IPOS
  112. ITOS=IPOS
  113. 152 CONTINUE
  114. SEGDES MLREE1
  115. SEGDES MLREEL
  116. *
  117. JG=LCAS
  118. SEGINI MLENT1
  119. MTAB1 = ITABO
  120. SEGACT MTAB1
  121. DO 120 I=1,LCAS
  122. IT=LECT(I)+IDEPAR-1
  123. MTAB2 = MTAB1.MTABIV(IT)
  124. SEGACT MTAB2
  125. MLENT1.LECT(I)= MTAB2.MTABIV(ICHA)
  126. SEGDES MTAB2
  127. 120 CONTINUE
  128. SEGDES MLENT1
  129. SEGSUP MLENTI
  130. ILEX=MLENT1
  131. GO TO 5001
  132. C
  133. C ****** CAS ITOUS=1 *************************
  134. C
  135. 10 CONTINUE
  136. C
  137. CALL COPIE4 (LBO, IPX)
  138. JG=LTE
  139. SEGINI MLENTI
  140. MTAB1 = ITABO
  141. SEGACT MTAB1
  142. IT=IDEPAR-1
  143. DO 1110 I=1,LTE
  144. IT=IT+1
  145. MTAB2 = MTAB1.MTABIV(IT)
  146. SEGACT MTAB2
  147. LECT (I)= MTAB2.MTABIV(ICHA)
  148. SEGDES MTAB2
  149. 1110 CONTINUE
  150. SEGDES MLENTI
  151. 11 CONTINUE
  152. ILEX=MLENTI
  153. 5001 ITYPE='TEMPS'
  154. SEGDES MTAB1
  155. MLENTI = ILEX
  156. SEGACT MLENTI
  157. JGG=LECT(/1)
  158. SEGDES MLENTI
  159. 5000 CONTINUE
  160. RETURN
  161. END
  162.  
  163.  
  164.  
  165.  

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