1 : C EXTRA6 SOURCE BP208322 13/09/12 21:15:01 7823 2 : SUBROUTINE EXTRA6(IBOLL) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C 6 : C ===================================================================== 7 : C 8 : C EXTRAIT UNE LISTE DE REELS ou autre D'UN OBJET EVOL 9 : C OU UNE COURBE (EVOL ELEMENTAIRE) 10 : C OU CERTAINS COUPLES 11 : C 12 : C APPELE PAR EXTRAI 13 : C 14 : C ===================================================================== 15 : C 16 : C CREATION : 12/05/87 17 : C PROGRAMMEUR : GUILBAUD 18 : C Modification : PM 12/09/2007, 19 : C définition de la couleur et du type de l'évolution 20 : C extraite 21 : c bp 12/09/2013: erreur 1027 pour les EVOLUTIOns vides 22 : C 23 : C ===================================================================== 24 : C 25 : -INC CCOPTIO 26 : -INC SMEVOLL 27 : -INC SMTEXTE 28 : CHARACTER*12 TI,ITEX,CHAR1,CHAR2 29 : CHARACTER*8 ITBLA,TYPRES 30 : 31 : C 32 : C VERIF QUE L'EVOLUTION N'EST PAS VIDE 33 : C 34 : MEVOLL=IBOLL 35 : SEGACT MEVOLL 36 : NBEV = IEVOLL(/1) 37 : if(NBEV.le.0) then 38 : MOTERR(1:8)='EVOLUTIO' 39 : C Une donnée de type %m1:8 est vide 39 : CALL ERREUR(1027) 40 : GOTO 80 41 : endif 42 : C 43 : C LECTURE DU TITRE DE LA PROGRESSION 44 : C 45 : TYPRES='LISTREEL' 46 : ITBLA=' ' 46 : CALL QUETYP(ITBLA,0,IRETOU) 47 : IF(ITBLA.EQ.'MOT ') THEN 48 : C 49 : C ON VA LIRE UN MOT 50 : C 50 : CALL LIRCHA(TI,1,IRETOU) 51 : 52 : C On extrait la légende en X 53 : IF(TI(:4).EQ.'LEGX')THEN 53 : CALL LIRENT(K,1,IRETOU) 54 : if(K.LE.0)THEN 54 : CALL ERREUR(352) 55 : RETURN 56 : ENDIF 57 : c MEVOLL=IBOLL 58 : c SEGACT MEVOLL 59 : if(K.GT.IEVOLL(/1))THEN 60 : c Il n'y a pas %i1 courbes dans l'objet évolution 61 : INTERR(1)=K 61 : CALL ERREUR(351) 62 : SEGDES MEVOLL 63 : RETURN 64 : ENDIF 65 : 66 : KEVOLL = IEVOLL(K) 67 : SEGACT KEVOLL 68 : ITEX=NOMEVX 69 : SEGDES KEVOLL,MEVOLL 69 : CALL ECRCHA(ITEX) 70 : RETURN 71 : ENDIF 72 : 73 : C On extrait la légende en Y 74 : IF(TI(:4).EQ.'LEGY')THEN 74 : CALL LIRENT(K,1,IRETOU) 75 : if(K.LE.0)THEN 75 : CALL ERREUR(352) 76 : RETURN 77 : ENDIF 78 : c MEVOLL=IBOLL 79 : c SEGACT MEVOLL 80 : if(K.GT.IEVOLL(/1))THEN 80 : CALL ERREUR(351) 81 : RETURN 82 : ENDIF 83 : 84 : KEVOLL = IEVOLL(K) 85 : SEGACT KEVOLL 86 : ITEX=NOMEVY 87 : SEGDES KEVOLL,MEVOLL 87 : CALL ECRCHA(ITEX) 88 : RETURN 89 : ENDIF 90 : 91 : IF (TI(:4).EQ.'ABSC'.OR.TI(:4).EQ.'ORDO'.OR.TI(:4).EQ.'COUR') 92 : & GOTO 25 93 : * 94 : IF (TI(:4).EQ.'PAS '.OR.TI(:4).EQ.'APRE'.OR.TI(:4).EQ.'AVAN') 95 : & GOTO 26 96 : * 97 : ELSE 98 : C 99 : C ON LIT AUTRE CHOSE 100 : C 100 : CALL LIROBJ(ITBLA,MOT1,1,IRETOU) 101 : C On ne veut pas d'objet de type %m1:8 102 : MOTERR(1:8)=ITBLA 102 : CALL ERREUR(39) 103 : RETURN 104 : ENDIF 105 : C 106 : C RECHERCHE DE LA PROGRESSION 107 : C 108 : c MEVOLL=IBOLL 109 : c SEGACT MEVOLL 110 : NBEV=IEVOLL(/1) 111 : DO J=1,NBEV 112 : KEVOLL=IEVOLL(J) 113 : SEGACT KEVOLL 114 : ITEX=NOMEVX 115 : IRET=IPROGX 116 : SEGDES KEVOLL 117 : IF(TI.EQ.ITEX) GOTO 30 118 : SEGACT KEVOLL 119 : ITEX=NOMEVY 120 : IRET=IPROGY 121 : SEGDES KEVOLL 122 : IF(TI.EQ.ITEX) GOTO 30 123 : ENDDO 124 : 125 : C Il n'existe pas de liste ayant ce titre dans l'objet évolution 125 : CALL ERREUR(353) 126 : GOTO 80 127 : * 128 : * EXTRACTION DE CERTAINS COUPLES 129 : * 130 : 26 CONTINUE 130 : CALL TEVOLU(IBOLL,TI) 131 : RETURN 132 : * 133 : * AUTRE OPERATION 134 : * 135 : 25 CONTINUE 136 : c MEVOLL=IBOLL 137 : c SEGACT MEVOLL 138 : C 139 : C ON A LU UN MOT-CLE 140 : C 141 : C 142 : C EXTRAIRE LES COURBES DE NOMS D'ABSCISSES OU D'ORDONNEES DONNES 143 : C 143 : CALL LIRCHA(ITEX,0,IRETOU) 144 : IF (IRETOU.NE.0.AND.TI(:4).EQ.'COUR') THEN 145 : NBEV=IEVOLL(/1) 146 : N=NBEV 147 : SEGINI,MEVOL1 148 : MEVOL1.ITYEVO=ITYEVO 149 : MEVOL1.IEVTEX=IEVTEX 150 : N=0 151 : DO IK=1,NBEV 152 : KEVOLL=MEVOLL.IEVOLL(IK) 153 : SEGACT,KEVOLL 154 : CHAR1=NOMEVX 155 : CHAR2=NOMEVY 156 : * write(6,*) 'CHAR1 =',CHAR1 157 : * write(6,*) 'CHAR2 =',CHAR2 158 : IF (ITEX(1:12).EQ.CHAR1.OR.ITEX(1:12).EQ.CHAR2) THEN 159 : N=N+1 160 : MEVOL1.IEVOLL(N)=KEVOLL 161 : ENDIF 162 : SEGDES,KEVOLL 163 : ENDDO 164 : * write(6,*) 'N =',N 165 : IF (N.NE.0) THEN 166 : SEGADJ,MEVOL1 167 : IRET=MEVOL1 168 : SEGDES,MEVOL1 168 : CALL ECROBJ('EVOLUTIO',IRET) 169 : ELSE 170 : SEGSUP,MEVOL1 170 : CALL ERREUR(353) 171 : ENDIF 172 : GOTO 80 173 : ENDIF 174 : C 175 : C EXTRAIRE LA COURBE J 176 : C 176 : CALL LIRENT(J,0,IRETOU) 177 : IF(IRETOU.EQ.0) THEN 178 : J=1 179 : ELSE 180 : IF(J.GT.IEVOLL(/1)) THEN 181 : * Il n'y a pas %i1 courbes dans l'objet évolution 182 : INTERR(1)=J 182 : CALL ERREUR(351) 183 : GOTO 80 184 : ENDIF 185 : IF(J.LE.0) THEN 186 : C Numéro de la courbe négatif ou nul 186 : CALL ERREUR(352) 187 : GOTO 80 188 : ENDIF 189 : ENDIF 190 : 191 : KEVOLL=IEVOLL(J) 192 : SEGACT KEVOLL 193 : IF(TI(:4).EQ.'COUR') THEN 194 : N=1 195 : SEGINI MEVOL1 196 : MEVOL1.IEVTEX = KEVTEX 197 : MEVOL1.ITYEVO = 'REEL' 198 : MEVOL1.IEVOLL(1)= KEVOLL 199 : IRET=MEVOL1 200 : SEGDES MEVOL1 201 : SEGDES KEVOLL 201 : CALL ECROBJ('EVOLUTIO',IRET) 202 : GOTO 80 203 : ENDIF 204 : 205 : C 206 : C EXTRAIRE LES LISTES D'ABSCISSES (DEFAUT) OU D'ORDONNEES 207 : C 208 : IRET=IPROGX 209 : TYPRES=TYPX 210 : IF(TI(:4).EQ.'ORDO') THEN 211 : IRET = IPROGY 212 : TYPRES= TYPY 213 : ENDIF 214 : SEGDES KEVOLL 215 : 216 : 30 CONTINUE 216 : CALL ECROBJ(TYPRES,IRET) 217 : 218 : 80 CONTINUE 219 : SEGDES MEVOLL 220 : RETURN 221 : 222 : END 223 : 224 : 225 : 226 : 227 : 228 : 229 :
© Cast3M 2003 - All rights reserved.
Disclaimer