C SOREXC SOURCE GOUNAND 13/01/10 21:15:01 7662 ************************************************************************ * NOM : sorexc.eso * DESCRIPTION : Sortie de données tabulaires au format CSV (Comma- * Separated Values, pour Excel ou Matlab par exemple) ************************************************************************ * HISTORIQUE : 26/11/2003 : CHAT : version initiale * HISTORIQUE : 12/01/2010 : FANDEUR : deplacement du code de prsort.eso * vers sorexc.eso * HISTORIQUE : 19/07/2011 : FANDEUR : correction anomalie 7035 * HISTORIQUE : 7/06/2012 : JCARDO : ajout des options NCOL et SEPA * + sortie de LISTENTI/LISTMOTS * + ajout de l'extension CSV * + fermeture du fichier * HISTORIQUE : ************************************************************************ * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES * en cas de modification de ce sous-programme afin de faciliter * la maintenance ! ************************************************************************ * APPELÉ PAR : opérateur SORTir (prsort.eso) ************************************************************************ * ENTRÉES :: aucune * SORTIES :: aucune (sur fichier uniquement) ************************************************************************ * SYNTAXE (GIBIANE) : * * SORT 'EXCE' OBJ1 (... OBJn) ('NCOL' ENTI1) ('SEPA' |'PVIR'|) * |'VIRG'| * |'ESPA'| * |'TABU'| * |'OBLI'| * * avec OBJi = [ LENTIi | LREELi | LMOTSi | EVOLi | TABi ] * ************************************************************************ SUBROUTINE SOREXC IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC CCOPTIO -INC SMTABLE -INC SMLREEL -INC SMLENTI -INC SMLMOTS -INC SMEVOLL CHARACTER*1 CHA1 CHARACTER*4 CHA4 CHARACTER*8 CHA8 CHARACTER*12 CH12 CHARACTER*20 MYFMT CHARACTER*256 FICEXC LOGICAL ZOPEN SEGMENT TRAV CHARACTER*12 TITCOL(M) CHARACTER*8 TYPCOL(M) INTEGER NUMCOL(M) REAL*8 XX(N,M1) INTEGER II(N,M2) CHARACTER*4 CC(N,M3) ENDSEGMENT SEGMENT TRAV2 CHARACTER*12 CHARAC(NBCOL) ENDSEGMENT LOGICAL B_Z PARAMETER(NCLE=2) CHARACTER*4 LCLE(NCLE) PARAMETER(NSEP=5) INTEGER LISEP(NSEP) CHARACTER*4 LMSEP(NSEP) CHARACTER*1 CHSEP PARAMETER(NTYP=3) CHARACTER*8 LTYP(NTYP) INTEGER ITYP(2) EXTERNAL LONG DATA LCLE /'NCOL','SEPA'/ DATA LMSEP /'TABU','VIRG','PVIR','ESPA','OBLI'/ DATA LISEP / 9 , 44 , 59 , 32 , 47 / DATA LTYP /'LISTREEL','LISTENTI','LISTMOTS'/ M1=0 M2=0 M3=0 M=0 N=0 SEGINI,TRAV * Ajout de l'extension au nom du fichier INQUIRE(UNIT=IOPER,OPENED=ZOPEN) IF (.NOT.ZOPEN) THEN CALL ERREUR(-212) WRITE(IOIMP,*) '(via OPTI "SORT")' MOTERR(1:8)='CSV ' CALL ERREUR(705) RETURN ENDIF INQUIRE(UNIT=IOPER,NAME=NOMFIC) CLOSE(UNIT=IOPER,STATUS='DELETE') CALL LENCHA(NOMFIC,LC) FICEXC=NOMFIC(1:LC) IF (NOMFIC(LC-3:LC).NE.'.csv') FICEXC(LC+1:LC+4)='.csv' IOS=0 OPEN(UNIT=IOPER,STATUS='UNKNOWN',FILE=FICEXC(1:LONG(FICEXC)), & IOSTAT=IOS,FORM='FORMATTED') * +---------------------------------------------------------------+ * | | * | L E C T U R E D E S A R G U M E N T S | * | | * +---------------------------------------------------------------+ * Valeurs par défaut (nombre de colonnes et séparateur) NBCOL=0 ICSEP=LISEP(3) 1 CONTINUE CALL QUETYP(CHA8,0,IRETOU) IF (IRETOU.EQ.0) GOTO 900 IF (CHA8.EQ.'MOT') THEN CALL LIRMOT(LCLE,NCLE,ICLE,1) * MOT-CLÉ "NCOL" IF (ICLE.EQ.1) THEN CALL LIRENT(NBCOL,0,IRETOU) IF (IRETOU.EQ.0) THEN * ERREUR : Le mot-clé %m1:4 n'est pas suivi de la donnée correspondante MOTERR(1:4)=CHA8(1:4) CALL ERREUR(166) RETURN ENDIF IF (NBCOL.LT.1) THEN * ERREUR : On veut lire un entier supérieur ou égal à %i1 (on a lu : %i2) INTERR(1)=1 INTERR(2)=NBCOL CALL ERREUR(190) RETURN ENDIF * MOT-CLÉ "SEPA" ELSEIF (ICLE.EQ.2) THEN CALL LIRCHA(CHA4,1,LCHA) IF (IERR.NE.0) RETURN CALL PLACE(LMSEP,NSEP,ISEP,CHA4) IF (ISEP.EQ.0) THEN * ERREUR : On ne comprend pas le mot %m1:4 MOTERR(1:4)=CHA4 CALL ERREUR(7) RETURN ENDIF ICSEP=LISEP(ISEP) ENDIF * ============================ * LECTURE D'UN OBJET TABLE * ============================ ELSEIF (CHA8.EQ.'TABLE') THEN CALL LIROBJ('TABLE ',MTABLE,1,IRETOU) IF (IERR.NE.0) RETURN CALL ECROBJ('TABLE ',MTABLE) CALL INDETA IF (IERR.NE.0) RETURN CALL LIROBJ('TABLE ',MTAB2,1,IRETOU) IF (IERR.NE.0) RETURN M10=M1 M20=M2 M30=M3 SEGACT,MTABLE DO I=1,MLOTAB IF (MTABTV(I).EQ.'LISTREEL') THEN M1=M1+1 MLREEL=MTABIV(I) SEGACT,MLREEL N=MAX(N,PROG(/1)) ELSEIF (MTABTV(I).EQ.'LISTENTI') THEN M2=M2+1 MLENTI=MTABIV(I) SEGACT,MLENTI N=MAX(N,LECT(/1)) ELSEIF (MTABTV(I).EQ.'LISTMOTS') THEN M3=M3+1 MLMOTS=MTABIV(I) SEGACT,MLMOTS N=MAX(N,MOTS(/2)) ELSE * ERREUR : On ne veut pas d'objet de type %m1:8 MOTERR(1:8)=MTABTV(I) CALL ERREUR(39) RETURN ENDIF ENDDO M=M1+M2+M3 SEGADJ,TRAV DO I=1,MLOTAB IF (MTABTV(I).EQ.'LISTREEL') THEN M10=M10+1 NUMCOL(M10+M20+M30)=M10 MLREEL=MTABIV(I) DO J=1,PROG(/1) XX(J,M10)=PROG(J) ENDDO SEGDES,MLREEL ELSEIF (MTABTV(I).EQ.'LISTENTI') THEN M20=M20+1 NUMCOL(M10+M20+M30)=M20 MLENTI=MTABIV(I) DO J=1,LECT(/1) II(J,M20)=LECT(J) ENDDO SEGDES,MLENTI ELSEIF (MTABTV(I).EQ.'LISTMOTS') THEN M30=M30+1 NUMCOL(M10+M20+M30)=M30 MLMOTS=MTABIV(I) DO J=1,MOTS(/2) CC(J,M30)=MOTS(J) ENDDO SEGDES,MLMOTS ENDIF M0=M10+M20+M30 TYPCOL(M0)=MTABTV(I) TITCOL(M0)=' ' IF (MTABTI(I).EQ.'MOT ') THEN CALL ACCTAB(MTAB2,'ENTIER ', I ,R_Z,CHA1,B_Z,I_Z, & 'MOT ',I_Z,R_Z,CH12,B_Z,I_Z) TITCOL(M0)=CH12 ENDIF ENDDO SEGDES,MTABLE SEGSUP,MTAB2 * ============================ * LECTURE D'UN OBJET EVOLUTION * ============================ ELSEIF (CHA8.EQ.'EVOLUTIO') THEN CALL LIROBJ('EVOLUTIO',MEVOLL,1,IRETOU) IF (IERR.NE.0) RETURN M10=M1 M20=M2 M30=M3 SEGACT,MEVOLL DO I=1,IEVOLL(/1) KEVOLL=IEVOLL(I) SEGACT,KEVOLL CALL PLACE(LTYP,NTYP,ITYP(1),TYPX) CALL PLACE(LTYP,NTYP,ITYP(2),TYPY) IF (ITYP(1).GT.0.AND.ITYP(2).GT.0) THEN DO J=1,2 IF (ITYP(J).EQ.1) THEN M1=M1+1 IF (J.EQ.1) THEN MLREEL=IPROGX ELSE MLREEL=IPROGY ENDIF SEGACT MLREEL NN=PROG(/1) ELSEIF (ITYP(J).EQ.2) THEN M2=M2+1 IF (J.EQ.1) THEN MLENTI=IPROGX ELSE MLENTI=IPROGY ENDIF SEGACT MLENTI NN=LECT(/1) ELSEIF (ITYP(J).EQ.3) THEN M3=M3+1 IF (J.EQ.1) THEN MLMOTS=IPROGX ELSE MLMOTS=IPROGY ENDIF SEGACT MLMOTS NN=MOTS(/2) ELSE CALL ERREUR(5) RETURN ENDIF ENDDO N=MAX(N,NN) ENDIF ENDDO * M=M1+M2+M3 SEGADJ,TRAV DO I=1,IEVOLL(/1) KEVOLL=IEVOLL(I) CALL PLACE(LTYP,NTYP,ITYP(1),TYPX) CALL PLACE(LTYP,NTYP,ITYP(2),TYPY) IF (ITYP(1).GT.0.AND.ITYP(2).GT.0) THEN DO J=1,2 IF (ITYP(J).EQ.1) THEN M10=M10+1 NUMCOL(M10+M20+M30)=M10 IF (J.EQ.1) THEN MLREEL=IPROGX ELSE MLREEL=IPROGY ENDIF DO K=1,PROG(/1) XX(K,M10)=PROG(K) ENDDO SEGDES MLREEL ELSEIF (ITYP(J).EQ.2) THEN M20=M20+1 NUMCOL(M10+M20+M30)=M20 IF (J.EQ.1) THEN MLENTI=IPROGX ELSE MLENTI=IPROGY ENDIF DO K=1,LECT(/1) II(K,M20)=LECT(K) ENDDO SEGDES MLENTI ELSEIF (ITYP(J).EQ.3) THEN M30=M30+1 NUMCOL(M10+M20+M30)=M30 IF (J.EQ.1) THEN MLMOTS=IPROGX ELSE MLMOTS=IPROGY ENDIF DO K=1,MOTS(/2) CC(K,M30)=MOTS(K) ENDDO SEGDES MLMOTS ELSE CALL ERREUR(5) RETURN ENDIF M0=M10+M20+M30 TYPCOL(M0)=LTYP(ITYP(J)) IF (J.EQ.1) THEN TITCOL(M0) =NOMEVX ELSE TITCOL(M0) =NOMEVY ENDIF ENDDO ENDIF SEGDES,KEVOLL ENDDO SEGDES,MEVOLL * =========================== * LECTURE D'UN OBJET LISTREEL * =========================== ELSEIF (CHA8.EQ.'LISTREEL') THEN CALL LIROBJ('LISTREEL',MLREEL,1,IRETOU) IF (IERR.NE.0) RETURN M1=M1+1 SEGACT,MLREEL N=MAX(N,PROG(/1)) M=M1+M2+M3 SEGADJ,TRAV NUMCOL(M)=M1 TYPCOL(M)='LISTREEL' TITCOL(M)=' ' DO I=1,PROG(/1) XX(I,M1)=PROG(I) ENDDO SEGDES,MLREEL * =========================== * LECTURE D'UN OBJET LISTENTI * =========================== ELSEIF (CHA8.EQ.'LISTENTI') THEN CALL LIROBJ('LISTENTI',MLENTI,1,IRETOU) IF (IERR.NE.0) RETURN M2=M2+1 SEGACT,MLENTI N=MAX(N,LECT(/1)) M=M1+M2+M3 SEGADJ,TRAV NUMCOL(M)=M2 TYPCOL(M)='LISTENTI' TITCOL(M)=' ' DO I=1,LECT(/1) II(I,M2)=LECT(I) ENDDO SEGDES,MLENTI * =========================== * LECTURE D'UN OBJET LISTMOTS * =========================== ELSEIF (CHA8.EQ.'LISTMOTS') THEN CALL LIROBJ('LISTMOTS',MLMOTS,1,IRETOU) IF (IERR.NE.0) RETURN M3=M3+1 SEGACT,MLMOTS N=MAX(N,MOTS(/2)) M=M1+M2+M3 SEGADJ,TRAV NUMCOL(M)=M3 TYPCOL(M)='LISTMOTS' TITCOL(M)=' ' DO I=1,MOTS(/2) CC(I,M3)=MOTS(I) ENDDO SEGDES,MLMOTS ELSE * ERREUR : On ne veut pas d'objet de type %m1:8 MOTERR(1:8)=CHA8 CALL ERREUR(39) RETURN ENDIF GOTO 1 ************************************************************************ ************************************************************************ ************************************************************************ ************************************************************************ * +---------------------------------------------------------------+ * | | * | É C R I T U R E D A N S L E F I C H I E R | * | | * +---------------------------------------------------------------+ 900 CONTINUE IF (M.EQ.0) THEN * Aucun objet compatible n'a été trouvé MOTERR( 1: 8)='TABLE ' MOTERR( 9:16)='EVOLUTIO' MOTERR(17:24)='LISTREEL' MOTERR(25:32)='LISTENTI' MOTERR(33:40)='LISTMOTS' CALL ERREUR(471) ELSE IF (N.EQ.0) THEN WRITE(IOIMP,*) 'ATTENTION : il n''y a rien à sortir' CALL ERREUR(21) ELSE ICOL=0 IF (NBCOL.EQ.0) NBCOL=M SEGINI,TRAV2 CHSEP=ACHAR(ICSEP) WRITE(MYFMT,'("(",I8,"(A12,''",A1,"''))")') NBCOL,CHSEP 901 CONTINUE KK=MIN(ICOL+NBCOL,M) WRITE(UNIT=IOPER,FMT=MYFMT) (TITCOL(K),K=ICOL+1,KK) DO J=1,N DO I=1,KK-ICOL K=ICOL+I IF (TYPCOL(K).EQ.'LISTREEL') THEN WRITE(CHARAC(I),FMT='(1PE12.5)') XX(J,NUMCOL(K)) ELSEIF (TYPCOL(K).EQ.'LISTENTI') THEN WRITE(CHARAC(I),FMT='(I12)') II(J,NUMCOL(K)) ELSEIF (TYPCOL(K).EQ.'LISTMOTS') THEN WRITE(CHARAC(I),FMT='(A12)') CC(J,NUMCOL(K)) ENDIF ENDDO WRITE(UNIT=IOPER,FMT=MYFMT) (CHARAC(I),I=1,KK-ICOL) ENDDO ICOL=ICOL+NBCOL IF (ICOL.LT.M) THEN WRITE(IOPER,996) WRITE(IOPER,996) WRITE(IOPER,996) GOTO 901 ENDIF ENDIF 996 FORMAT(A20) c 997 FORMAT(12(A12,';')) c 998 FORMAT(12(1PE12.5,';')) * Fermeture du fichier CLOSE(UNIT=IOPER) * Un peu de menage SEGSUP,TRAV RETURN END