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