1 : C SOREXC SOURCE GOUNAND 13/01/10 21:15:01 7662
2 : ************************************************************************
3 : * NOM : sorexc.eso
4 : * DESCRIPTION : Sortie de données tabulaires au format CSV (Comma-
5 : * Separated Values, pour Excel ou Matlab par exemple)
6 : ************************************************************************
7 : * HISTORIQUE : 26/11/2003 : CHAT : version initiale
8 : * HISTORIQUE : 12/01/2010 : FANDEUR : deplacement du code de prsort.eso
9 : * vers sorexc.eso
10 : * HISTORIQUE : 19/07/2011 : FANDEUR : correction anomalie 7035
11 : * HISTORIQUE : 7/06/2012 : JCARDO : ajout des options NCOL et SEPA
12 : * + sortie de LISTENTI/LISTMOTS
13 : * + ajout de l'extension CSV
14 : * + fermeture du fichier
15 : * HISTORIQUE :
16 : ************************************************************************
17 : * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
18 : * en cas de modification de ce sous-programme afin de faciliter
19 : * la maintenance !
20 : ************************************************************************
21 : * APPELÉ PAR : opérateur SORTir (prsort.eso)
22 : ************************************************************************
23 : * ENTRÉES :: aucune
24 : * SORTIES :: aucune (sur fichier uniquement)
25 : ************************************************************************
26 : * SYNTAXE (GIBIANE) :
27 : *
28 : * SORT 'EXCE' OBJ1 (... OBJn) ('NCOL' ENTI1) ('SEPA' |'PVIR'|)
29 : * |'VIRG'|
30 : * |'ESPA'|
31 : * |'TABU'|
32 : * |'OBLI'|
33 : *
34 : * avec OBJi = [ LENTIi | LREELi | LMOTSi | EVOLi | TABi ]
35 : *
36 : ************************************************************************
37 :
38 : SUBROUTINE SOREXC
39 :
40 : IMPLICIT INTEGER(I-N)
41 : IMPLICIT REAL*8(A-H,O-Z)
42 :
43 : -INC CCOPTIO
44 : -INC SMTABLE
45 : -INC SMLREEL
46 : -INC SMLENTI
47 : -INC SMLMOTS
48 : -INC SMEVOLL
49 :
50 : CHARACTER*1 CHA1
51 : CHARACTER*4 CHA4
52 : CHARACTER*8 CHA8
53 : CHARACTER*12 CH12
54 : CHARACTER*20 MYFMT
55 :
56 : CHARACTER*256 FICEXC
57 : LOGICAL ZOPEN
58 :
59 : SEGMENT TRAV
60 : CHARACTER*12 TITCOL(M)
61 : CHARACTER*8 TYPCOL(M)
62 : INTEGER NUMCOL(M)
63 : REAL*8 XX(N,M1)
64 : INTEGER II(N,M2)
65 : CHARACTER*4 CC(N,M3)
66 : ENDSEGMENT
67 :
68 : SEGMENT TRAV2
69 : CHARACTER*12 CHARAC(NBCOL)
70 : ENDSEGMENT
71 :
72 : LOGICAL B_Z
73 :
74 : PARAMETER(NCLE=2)
75 : CHARACTER*4 LCLE(NCLE)
76 :
77 : PARAMETER(NSEP=5)
78 : INTEGER LISEP(NSEP)
79 : CHARACTER*4 LMSEP(NSEP)
80 : CHARACTER*1 CHSEP
81 :
82 : PARAMETER(NTYP=3)
83 : CHARACTER*8 LTYP(NTYP)
84 : INTEGER ITYP(2)
85 :
86 :
87 :
88 :
89 : EXTERNAL LONG
90 :
91 : DATA LCLE /'NCOL','SEPA'/
92 : DATA LMSEP /'TABU','VIRG','PVIR','ESPA','OBLI'/
93 : DATA LISEP / 9 , 44 , 59 , 32 , 47 /
94 : DATA LTYP /'LISTREEL','LISTENTI','LISTMOTS'/
95 :
96 :
97 : M1=0
98 : M2=0
99 : M3=0
100 : M=0
101 : N=0
102 : SEGINI,TRAV
103 :
104 :
105 :
106 : * Ajout de l'extension au nom du fichier
107 : INQUIRE(UNIT=IOPER,OPENED=ZOPEN)
108 : IF (.NOT.ZOPEN) THEN
108 : CALL ERREUR(-212)
109 : WRITE(IOIMP,*) '(via OPTI "SORT")'
110 : MOTERR(1:8)='CSV '
110 : CALL ERREUR(705)
111 : RETURN
112 : ENDIF
113 :
114 : INQUIRE(UNIT=IOPER,NAME=NOMFIC)
115 : CLOSE(UNIT=IOPER,STATUS='DELETE')
116 :
116 : CALL LENCHA(NOMFIC,LC)
117 : FICEXC=NOMFIC(1:LC)
118 : IF (NOMFIC(LC-3:LC).NE.'.csv') FICEXC(LC+1:LC+4)='.csv'
119 : IOS=0
120 : OPEN(UNIT=IOPER,STATUS='UNKNOWN',FILE=FICEXC(1:LONG(FICEXC)),
121 : & IOSTAT=IOS,FORM='FORMATTED')
122 :
123 :
124 :
125 :
126 : * +---------------------------------------------------------------+
127 : * | |
128 : * | L E C T U R E D E S A R G U M E N T S |
129 : * | |
130 : * +---------------------------------------------------------------+
131 :
132 : * Valeurs par défaut (nombre de colonnes et séparateur)
133 : NBCOL=0
134 : ICSEP=LISEP(3)
135 :
136 :
137 : 1 CONTINUE
138 :
138 : CALL QUETYP(CHA8,0,IRETOU)
139 : IF (IRETOU.EQ.0) GOTO 900
140 :
141 : IF (CHA8.EQ.'MOT') THEN
141 : CALL LIRMOT(LCLE,NCLE,ICLE,1)
142 :
143 : * MOT-CLÉ "NCOL"
144 : IF (ICLE.EQ.1) THEN
144 : CALL LIRENT(NBCOL,0,IRETOU)
145 : IF (IRETOU.EQ.0) THEN
146 : * ERREUR : Le mot-clé %m1:4 n'est pas suivi de la donnée correspondante
147 : MOTERR(1:4)=CHA8(1:4)
147 : CALL ERREUR(166)
148 : RETURN
149 : ENDIF
150 :
151 : IF (NBCOL.LT.1) THEN
152 : * ERREUR : On veut lire un entier supérieur ou égal à %i1 (on a lu : %i2)
153 : INTERR(1)=1
154 : INTERR(2)=NBCOL
154 : CALL ERREUR(190)
155 : RETURN
156 : ENDIF
157 :
158 : * MOT-CLÉ "SEPA"
159 : ELSEIF (ICLE.EQ.2) THEN
159 : CALL LIRCHA(CHA4,1,LCHA)
160 : IF (IERR.NE.0) RETURN
161 :
161 : CALL PLACE(LMSEP,NSEP,ISEP,CHA4)
162 : IF (ISEP.EQ.0) THEN
163 : * ERREUR : On ne comprend pas le mot %m1:4
164 : MOTERR(1:4)=CHA4
164 : CALL ERREUR(7)
165 : RETURN
166 : ENDIF
167 :
168 : ICSEP=LISEP(ISEP)
169 : ENDIF
170 :
171 :
172 :
173 :
174 : * ============================
175 : * LECTURE D'UN OBJET TABLE
176 : * ============================
177 :
178 : ELSEIF (CHA8.EQ.'TABLE') THEN
179 :
179 : CALL LIROBJ('TABLE ',MTABLE,1,IRETOU)
180 : IF (IERR.NE.0) RETURN
181 :
181 : CALL ECROBJ('TABLE ',MTABLE)
181 : CALL INDETA
182 : IF (IERR.NE.0) RETURN
182 : CALL LIROBJ('TABLE ',MTAB2,1,IRETOU)
183 : IF (IERR.NE.0) RETURN
184 :
185 : M10=M1
186 : M20=M2
187 : M30=M3
188 :
189 : SEGACT,MTABLE
190 : DO I=1,MLOTAB
191 : IF (MTABTV(I).EQ.'LISTREEL') THEN
192 : M1=M1+1
193 : MLREEL=MTABIV(I)
194 : SEGACT,MLREEL
195 : N=MAX(N,PROG(/1))
196 : ELSEIF (MTABTV(I).EQ.'LISTENTI') THEN
197 : M2=M2+1
198 : MLENTI=MTABIV(I)
199 : SEGACT,MLENTI
200 : N=MAX(N,LECT(/1))
201 : ELSEIF (MTABTV(I).EQ.'LISTMOTS') THEN
202 : M3=M3+1
203 : MLMOTS=MTABIV(I)
204 : SEGACT,MLMOTS
205 : N=MAX(N,MOTS(/2))
206 : ELSE
207 : * ERREUR : On ne veut pas d'objet de type %m1:8
208 : MOTERR(1:8)=MTABTV(I)
208 : CALL ERREUR(39)
209 : RETURN
210 : ENDIF
211 : ENDDO
212 :
213 : M=M1+M2+M3
214 : SEGADJ,TRAV
215 :
216 : DO I=1,MLOTAB
217 : IF (MTABTV(I).EQ.'LISTREEL') THEN
218 : M10=M10+1
219 : NUMCOL(M10+M20+M30)=M10
220 : MLREEL=MTABIV(I)
221 : DO J=1,PROG(/1)
222 : XX(J,M10)=PROG(J)
223 : ENDDO
224 : SEGDES,MLREEL
225 : ELSEIF (MTABTV(I).EQ.'LISTENTI') THEN
226 : M20=M20+1
227 : NUMCOL(M10+M20+M30)=M20
228 : MLENTI=MTABIV(I)
229 : DO J=1,LECT(/1)
230 : II(J,M20)=LECT(J)
231 : ENDDO
232 : SEGDES,MLENTI
233 : ELSEIF (MTABTV(I).EQ.'LISTMOTS') THEN
234 : M30=M30+1
235 : NUMCOL(M10+M20+M30)=M30
236 : MLMOTS=MTABIV(I)
237 : DO J=1,MOTS(/2)
238 : CC(J,M30)=MOTS(J)
239 : ENDDO
240 : SEGDES,MLMOTS
241 : ENDIF
242 :
243 : M0=M10+M20+M30
244 : TYPCOL(M0)=MTABTV(I)
245 : TITCOL(M0)=' '
246 : IF (MTABTI(I).EQ.'MOT ') THEN
246 : CALL ACCTAB(MTAB2,'ENTIER ', I ,R_Z,CHA1,B_Z,I_Z,
247 : & 'MOT ',I_Z,R_Z,CH12,B_Z,I_Z)
248 : TITCOL(M0)=CH12
249 : ENDIF
250 : ENDDO
251 :
252 : SEGDES,MTABLE
253 : SEGSUP,MTAB2
254 :
255 :
256 :
257 :
258 : * ============================
259 : * LECTURE D'UN OBJET EVOLUTION
260 : * ============================
261 :
262 : ELSEIF (CHA8.EQ.'EVOLUTIO') THEN
263 :
263 : CALL LIROBJ('EVOLUTIO',MEVOLL,1,IRETOU)
264 : IF (IERR.NE.0) RETURN
265 :
266 : M10=M1
267 : M20=M2
268 : M30=M3
269 :
270 : SEGACT,MEVOLL
271 : DO I=1,IEVOLL(/1)
272 : KEVOLL=IEVOLL(I)
273 : SEGACT,KEVOLL
273 : CALL PLACE(LTYP,NTYP,ITYP(1),TYPX)
273 : CALL PLACE(LTYP,NTYP,ITYP(2),TYPY)
274 : IF (ITYP(1).GT.0.AND.ITYP(2).GT.0) THEN
275 : DO J=1,2
276 : IF (ITYP(J).EQ.1) THEN
277 : M1=M1+1
278 : IF (J.EQ.1) THEN
279 : MLREEL=IPROGX
280 : ELSE
281 : MLREEL=IPROGY
282 : ENDIF
283 : SEGACT MLREEL
284 : NN=PROG(/1)
285 : ELSEIF (ITYP(J).EQ.2) THEN
286 : M2=M2+1
287 : IF (J.EQ.1) THEN
288 : MLENTI=IPROGX
289 : ELSE
290 : MLENTI=IPROGY
291 : ENDIF
292 : SEGACT MLENTI
293 : NN=LECT(/1)
294 : ELSEIF (ITYP(J).EQ.3) THEN
295 : M3=M3+1
296 : IF (J.EQ.1) THEN
297 : MLMOTS=IPROGX
298 : ELSE
299 : MLMOTS=IPROGY
300 : ENDIF
301 : SEGACT MLMOTS
302 : NN=MOTS(/2)
303 : ELSE
303 : CALL ERREUR(5)
304 : RETURN
305 : ENDIF
306 : ENDDO
307 : N=MAX(N,NN)
308 : ENDIF
309 : ENDDO
310 : *
311 : M=M1+M2+M3
312 : SEGADJ,TRAV
313 : DO I=1,IEVOLL(/1)
314 : KEVOLL=IEVOLL(I)
314 : CALL PLACE(LTYP,NTYP,ITYP(1),TYPX)
314 : CALL PLACE(LTYP,NTYP,ITYP(2),TYPY)
315 : IF (ITYP(1).GT.0.AND.ITYP(2).GT.0) THEN
316 : DO J=1,2
317 : IF (ITYP(J).EQ.1) THEN
318 : M10=M10+1
319 : NUMCOL(M10+M20+M30)=M10
320 : IF (J.EQ.1) THEN
321 : MLREEL=IPROGX
322 : ELSE
323 : MLREEL=IPROGY
324 : ENDIF
325 : DO K=1,PROG(/1)
326 : XX(K,M10)=PROG(K)
327 : ENDDO
328 : SEGDES MLREEL
329 : ELSEIF (ITYP(J).EQ.2) THEN
330 : M20=M20+1
331 : NUMCOL(M10+M20+M30)=M20
332 : IF (J.EQ.1) THEN
333 : MLENTI=IPROGX
334 : ELSE
335 : MLENTI=IPROGY
336 : ENDIF
337 : DO K=1,LECT(/1)
338 : II(K,M20)=LECT(K)
339 : ENDDO
340 : SEGDES MLENTI
341 : ELSEIF (ITYP(J).EQ.3) THEN
342 : M30=M30+1
343 : NUMCOL(M10+M20+M30)=M30
344 : IF (J.EQ.1) THEN
345 : MLMOTS=IPROGX
346 : ELSE
347 : MLMOTS=IPROGY
348 : ENDIF
349 : DO K=1,MOTS(/2)
350 : CC(K,M30)=MOTS(K)
351 : ENDDO
352 : SEGDES MLMOTS
353 : ELSE
353 : CALL ERREUR(5)
354 : RETURN
355 : ENDIF
356 : M0=M10+M20+M30
357 : TYPCOL(M0)=LTYP(ITYP(J))
358 : IF (J.EQ.1) THEN
359 : TITCOL(M0) =NOMEVX
360 : ELSE
361 : TITCOL(M0) =NOMEVY
362 : ENDIF
363 : ENDDO
364 : ENDIF
365 : SEGDES,KEVOLL
366 : ENDDO
367 : SEGDES,MEVOLL
368 :
369 : * ===========================
370 : * LECTURE D'UN OBJET LISTREEL
371 : * ===========================
372 :
373 : ELSEIF (CHA8.EQ.'LISTREEL') THEN
374 :
374 : CALL LIROBJ('LISTREEL',MLREEL,1,IRETOU)
375 : IF (IERR.NE.0) RETURN
376 :
377 : M1=M1+1
378 : SEGACT,MLREEL
379 : N=MAX(N,PROG(/1))
380 :
381 : M=M1+M2+M3
382 : SEGADJ,TRAV
383 :
384 : NUMCOL(M)=M1
385 : TYPCOL(M)='LISTREEL'
386 : TITCOL(M)=' '
387 : DO I=1,PROG(/1)
388 : XX(I,M1)=PROG(I)
389 : ENDDO
390 :
391 : SEGDES,MLREEL
392 :
393 :
394 :
395 : * ===========================
396 : * LECTURE D'UN OBJET LISTENTI
397 : * ===========================
398 :
399 : ELSEIF (CHA8.EQ.'LISTENTI') THEN
400 :
400 : CALL LIROBJ('LISTENTI',MLENTI,1,IRETOU)
401 : IF (IERR.NE.0) RETURN
402 :
403 : M2=M2+1
404 : SEGACT,MLENTI
405 : N=MAX(N,LECT(/1))
406 :
407 : M=M1+M2+M3
408 : SEGADJ,TRAV
409 :
410 : NUMCOL(M)=M2
411 : TYPCOL(M)='LISTENTI'
412 : TITCOL(M)=' '
413 : DO I=1,LECT(/1)
414 : II(I,M2)=LECT(I)
415 : ENDDO
416 :
417 : SEGDES,MLENTI
418 :
419 :
420 :
421 : * ===========================
422 : * LECTURE D'UN OBJET LISTMOTS
423 : * ===========================
424 :
425 : ELSEIF (CHA8.EQ.'LISTMOTS') THEN
426 :
426 : CALL LIROBJ('LISTMOTS',MLMOTS,1,IRETOU)
427 : IF (IERR.NE.0) RETURN
428 :
429 : M3=M3+1
430 : SEGACT,MLMOTS
431 : N=MAX(N,MOTS(/2))
432 :
433 : M=M1+M2+M3
434 : SEGADJ,TRAV
435 :
436 : NUMCOL(M)=M3
437 : TYPCOL(M)='LISTMOTS'
438 : TITCOL(M)=' '
439 : DO I=1,MOTS(/2)
440 : CC(I,M3)=MOTS(I)
441 : ENDDO
442 :
443 : SEGDES,MLMOTS
444 :
445 :
446 : ELSE
447 : * ERREUR : On ne veut pas d'objet de type %m1:8
448 : MOTERR(1:8)=CHA8
448 : CALL ERREUR(39)
449 : RETURN
450 : ENDIF
451 :
452 :
453 : GOTO 1
454 :
455 :
456 : ************************************************************************
457 : ************************************************************************
458 : ************************************************************************
459 : ************************************************************************
460 :
461 :
462 :
463 :
464 : * +---------------------------------------------------------------+
465 : * | |
466 : * | É C R I T U R E D A N S L E F I C H I E R |
467 : * | |
468 : * +---------------------------------------------------------------+
469 :
470 : 900 CONTINUE
471 : IF (M.EQ.0) THEN
472 : * Aucun objet compatible n'a été trouvé
473 : MOTERR( 1: 8)='TABLE '
474 : MOTERR( 9:16)='EVOLUTIO'
475 : MOTERR(17:24)='LISTREEL'
476 : MOTERR(25:32)='LISTENTI'
477 : MOTERR(33:40)='LISTMOTS'
477 : CALL ERREUR(471)
478 : ELSE IF (N.EQ.0) THEN
479 : WRITE(IOIMP,*) 'ATTENTION : il n''y a rien à sortir'
479 : CALL ERREUR(21)
480 : ELSE
481 : ICOL=0
482 : IF (NBCOL.EQ.0) NBCOL=M
483 : SEGINI,TRAV2
484 :
485 : CHSEP=ACHAR(ICSEP)
486 : WRITE(MYFMT,'("(",I8,"(A12,''",A1,"''))")') NBCOL,CHSEP
487 :
488 :
489 : 901 CONTINUE
490 : KK=MIN(ICOL+NBCOL,M)
491 :
492 : WRITE(UNIT=IOPER,FMT=MYFMT) (TITCOL(K),K=ICOL+1,KK)
493 : DO J=1,N
494 : DO I=1,KK-ICOL
495 : K=ICOL+I
496 : IF (TYPCOL(K).EQ.'LISTREEL') THEN
497 : WRITE(CHARAC(I),FMT='(1PE12.5)') XX(J,NUMCOL(K))
498 : ELSEIF (TYPCOL(K).EQ.'LISTENTI') THEN
499 : WRITE(CHARAC(I),FMT='(I12)') II(J,NUMCOL(K))
500 : ELSEIF (TYPCOL(K).EQ.'LISTMOTS') THEN
501 : WRITE(CHARAC(I),FMT='(A12)') CC(J,NUMCOL(K))
502 : ENDIF
503 : ENDDO
504 : WRITE(UNIT=IOPER,FMT=MYFMT) (CHARAC(I),I=1,KK-ICOL)
505 : ENDDO
506 : ICOL=ICOL+NBCOL
507 : IF (ICOL.LT.M) THEN
508 : WRITE(IOPER,996)
509 : WRITE(IOPER,996)
510 : WRITE(IOPER,996)
511 : GOTO 901
512 : ENDIF
513 : ENDIF
514 : 996 FORMAT(A20)
515 : c 997 FORMAT(12(A12,';'))
516 : c 998 FORMAT(12(1PE12.5,';'))
517 :
518 :
519 : * Fermeture du fichier
520 : CLOSE(UNIT=IOPER)
521 :
522 : * Un peu de menage
523 : SEGSUP,TRAV
524 :
525 : RETURN
526 : END
527 :
528 :
529 :
530 :
© Cast3M 2003 - All rights reserved.
Disclaimer