Télécharger la plaquette Cast3M


fr en

Télécharger verita.eso

Retour à la liste

Numérotation des lignes : 

verita

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

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