C SOREXC SOURCE OF166741 25/02/20 21:17:37 12165 C*********************************************************************** C NOM : sorexc.eso C DESCRIPTION : Sortie de données tabulaires au format CSV (Comma- C Separated Values, pour Excel ou Matlab par exemple) C*********************************************************************** C HISTORIQUE : 26/11/2003 : CHAT : version initiale C HISTORIQUE : 12/01/2010 : FANDEUR : deplacement du code de prsort.eso C vers sorexc.eso C HISTORIQUE : 19/07/2011 : FANDEUR : correction anomalie 7035 C HISTORIQUE : 07/06/2012 : JCARDO : ajout des options NCOL et SEPA C + sortie de LISTENTI/LISTMOTS C + ajout de l'extension CSV C + fermeture du fichier C HISTORIQUE : C*********************************************************************** C Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES C en cas de modification de ce sous-programme afin de faciliter C la maintenance ! C*********************************************************************** C APPELÉ PAR : opérateur SORTir (prsort.eso) C*********************************************************************** C ENTRÉES :: aucune C SORTIES :: aucune (sur fichier uniquement) C*********************************************************************** C SYNTAXE (GIBIANE) : C C SORT 'EXCE' OBJ1 (... OBJn) ('NCOL' ENTI1) ('SEPA' |'PVIR'|) C |'VIRG'| C |'ESPA'| C |'TABU'| C |'OBLI'| C C avec OBJi = [ LENTIi | LREELi | LMOTSi | EVOLi | TABi ] C C*********************************************************************** SUBROUTINE SOREXC IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) EXTERNAL LONG -INC CCNOYAU -INC PPARAM -INC CCOPTIO -INC SMTABLE -INC SMLREEL -INC SMLENTI -INC SMLMOTS -INC SMEVOLL CHARACTER*1 CHA1 CHARACTER*8 CHA8 CHARACTER*(LOCHAI) MOTI CHARACTER*20 MYFMT,MYFMT2,FMTFLO CHARACTER*(LOCHAI) FICEXC LOGICAL ZOPEN C Segment de travail contenant toutes les listes a ecrire dans le fichier CSV C M1 : nombre total de LISTREEL C M2 : nombre total de LISTENTI C M3 : nombre total de LISTMOTS C M : nombre total de listes (M = M1 + M2 + M3) SEGMENT TRAV CHARACTER*(LOCHAI) TITCOL(M) CHARACTER*8 TYPCOL(M) INTEGER NUMCOL(M),LONCOL(M) REAL*8 XX(N,M1) INTEGER II(N,M2) CHARACTER*(LONOM) CC(N,M3) ENDSEGMENT PARAMETER (NCHMAX=LOCHAI) SEGMENT TRAV2 * CHARACTER*12 CHARAC(NBCOL) CHARACTER*(LOCHAI) CHARAC(NBCOL) ENDSEGMENT LOGICAL B_Z PARAMETER(NCLE=3) 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) DATA LCLE /'NCOL','SEPA','DIGI'/ 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 C CB215821 : Dans les SORTIES on desactive toujours a mesure (pas de nouveau paradigme) C Sinon on peut avoir des soucis de memoire C 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 ='CSV' CALL ERREUR(705) RETURN ENDIF INQUIRE(UNIT=IOPER,NAME=FICEXC) CLOSE(UNIT=IOPER,STATUS='KEEP',IOSTAT=IOST1,ERR=9999) IF(IOST1 .NE. 0)GOTO 9998 CALL LENCHA(FICEXC,LC) IF ( (FICEXC(LC-3:LC).NE.'.csv') .AND. & (FICEXC(LC-3:LC).NE.'.CSV') ) THEN IF (LC+4.GT.LOCHAI) THEN write(ioimp,*) 'CSV Filename too long with extension' CALL ERREUR(1111) RETURN ENDIF FICEXC(LC+1:LC+4)='.csv' ENDIF IOS=0 OPEN(UNIT=IOPER,STATUS='UNKNOWN',FILE=FICEXC(1:LONG(FICEXC)), & IOSTAT=IOS,FORM='FORMATTED') C +---------------------------------------------------------------+ C | | C | L E C T U R E D E S M O T S C L E F S | C | | C +---------------------------------------------------------------+ C Valeurs par défaut (nombre de colonnes et séparateur) NBCOL=0 ICSEP=LISEP(3) NDIGIT=4 1 CONTINUE CALL LIRMOT(LCLE,NCLE,ICLE,0) C Mot clef "NCOL" IF (ICLE.EQ.1) THEN CALL LIRENT(NBCOL,0,IRETOU) IF (IRETOU.EQ.0) THEN C ERREUR : Le mot-clé %m1:4 n'est pas suivi de la donnée correspondante MOTERR =LCLE(ICLE) CALL ERREUR(166) RETURN ENDIF IF (NBCOL.LT.1) THEN C 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 GOTO 1 C Mot clef "SEPA" ELSEIF (ICLE.EQ.2) THEN CALL LIRMOT(LMSEP,NSEP,ISEP,0) IF (ISEP.EQ.0) THEN C ERREUR : Le mot-clé %m1:4 n'est pas suivi de la donnée correspondante MOTERR =LCLE(ICLE) CALL ERREUR(166) RETURN ENDIF ICSEP=LISEP(ISEP) GOTO 1 C Mot clef "DIGIT" ELSEIF (ICLE.EQ.3) THEN CALL LIRENT(NDIGIT,0,IRETOU) IF (IRETOU.EQ.0) THEN C ERREUR : Le mot-clé %m1:4 n'est pas suivi de la donnée correspondante MOTERR =LCLE(ICLE) CALL ERREUR(166) RETURN ENDIF IF (NDIGIT.LT.1) THEN C ERREUR : On veut lire un entier supérieur ou égal à %i1 (on a lu : %i2) INTERR(1)=1 INTERR(2)=NDIGIT CALL ERREUR(190) RETURN ENDIF GOTO 1 ENDIF * il faut que NCH soit < ou = NCHMAX (cf. taille de CHARAC) NCH=NDIGIT+8 NCH=MIN(NCH,NCHMAX) * NDIGIT=NCH-8 C +---------------------------------------------------------------+ C | | C | L E C T U R E D E S A R G U M E N T S | C | P R I N C I P A U X | C | E T R E M P L I S S A G E D U S E G M E N T T R A V | C | | C +---------------------------------------------------------------+ 2 CONTINUE CALL QUETYP(CHA8,0,IRETOU) IF (IRETOU.EQ.0) GOTO 900 C ============================ C LECTURE D'UN OBJET TABLE C ============================ IF (CHA8.EQ.'TABLE') THEN CALL LIROBJ('TABLE ',MTABLE,1,IRETOU) C Acquisition des LISTREEL, LISTENTI et LISTMOTS de la table CALL ECROBJ('TABLE ',MTABLE) CALL INDETA IF (IERR.NE.0) RETURN CALL LIROBJ('TABLE ',MTAB2,1,IRETOU) IF (IERR.NE.0) RETURN C La TABLE doit etre reactivee apres INDETA SEGACT,MTABLE,MTAB2 M10=M1 M20=M2 M30=M3 C Décompte DO I=1,MLOTAB IF (MTABTV(I) .EQ.'LISTREEL') THEN M1=M1+1 MLREEL=MTABIV(I) SEGACT,MLREEL N=MAX(N,PROG(/1)) SEGDES,MLREEL ELSEIF (MTABTV(I).EQ.'LISTENTI') THEN M2=M2+1 MLENTI=MTABIV(I) SEGACT,MLENTI N=MAX(N,LECT(/1)) SEGDES,MLENTI ELSEIF (MTABTV(I).EQ.'LISTMOTS') THEN M3=M3+1 MLMOTS=MTABIV(I) SEGACT,MLMOTS N=MAX(N,MOTS(/2)) SEGDES,MLMOTS ELSE C ERREUR : On ne veut pas d'objet de type %m1:8 MOTERR=MTABTV(I) CALL ERREUR(39) RETURN ENDIF ENDDO C Ajustement et copie des valeurs 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) SEGACT,MLREEL JMAX=PROG(/1) DO J=1,JMAX XX(J,M10)=PROG(J) ENDDO ELSEIF (MTABTV(I).EQ.'LISTENTI') THEN M20=M20+1 NUMCOL(M10+M20+M30)=M20 MLENTI=MTABIV(I) SEGACT,MLENTI JMAX=LECT(/1) DO J=1,JMAX II(J,M20)=LECT(J) ENDDO ELSEIF (MTABTV(I).EQ.'LISTMOTS') THEN M30=M30+1 NUMCOL(M10+M20+M30)=M30 MLMOTS=MTABIV(I) SEGACT,MLMOTS JMAX=MOTS(/2) DO J=1,JMAX MOTI=MOTS(J) NCH=MAX(NCH,LONG(MOTI)) CC(J,M30)=MOTI ENDDO ENDIF M0=M10+M20+M30 TYPCOL(M0)=MTABTV(I) LONCOL(M0)=JMAX 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,MOTI,B_Z,I_Z) TITCOL(M0)=MOTI NCH=MAX(NCH,LONG(MOTI)) ENDIF ENDDO SEGSUP,MTAB2 SEGDES,MTABLE C ============================ C LECTURE D'UN OBJET EVOLUTION C ============================ ELSEIF (CHA8.EQ.'EVOLUTIO') THEN CALL LIROBJ('EVOLUTIO',MEVOLL,1,IRETOU) IF (IERR.NE.0) RETURN CALL ACTOBJ('EVOLUTIO',MEVOLL,1) M10=M1 M20=M2 M30=M3 C Decompte 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 M1=M1+1 IF (J.EQ.1) THEN MLREEL=IPROGX ELSE MLREEL=IPROGY ENDIF NN=PROG(/1) ELSEIF (ITYP(J).EQ.2) THEN M2=M2+1 IF (J.EQ.1) THEN MLENTI=IPROGX ELSE MLENTI=IPROGY ENDIF NN=LECT(/1) ELSEIF (ITYP(J).EQ.3) THEN M3=M3+1 IF (J.EQ.1) THEN MLMOTS=IPROGX ELSE MLMOTS=IPROGY ENDIF NN=MOTS(/2) ELSE CALL ERREUR(5) RETURN ENDIF ENDDO N=MAX(N,NN) ENDIF ENDDO C Ajustement et copie des valeurs 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 KMAX=PROG(/1) DO K=1,KMAX XX(K,M10)=PROG(K) ENDDO 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 KMAX=LECT(/1) DO K=1,KMAX II(K,M20)=LECT(K) ENDDO 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 KMAX=MOTS(/2) DO K=1,KMAX MOTI=MOTS(K) NCH=MAX(NCH,LONG(MOTI)) CC(K,M30)=MOTI ENDDO ELSE CALL ERREUR(5) RETURN ENDIF M0=M10+M20+M30 TYPCOL(M0)=LTYP(ITYP(J)) LONCOL(M0)=KMAX IF (J.EQ.1) THEN TITCOL(M0) =NOMEVX ELSE TITCOL(M0) =NOMEVY ENDIF ENDDO ENDIF ENDDO C =========================== C LECTURE D'UN OBJET LISTREEL C =========================== 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' LONCOL(M)=PROG(/1) TITCOL(M)=' ' DO I=1,PROG(/1) XX(I,M1)=PROG(I) ENDDO C =========================== C LECTURE D'UN OBJET LISTENTI C =========================== 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' LONCOL(M)=LECT(/1) TITCOL(M)=' ' DO I=1,LECT(/1) II(I,M2)=LECT(I) ENDDO C =========================== C LECTURE D'UN OBJET LISTMOTS C =========================== 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' LONCOL(M)=MOTS(/2) TITCOL(M)=' ' DO I=1,MOTS(/2) MOTI=MOTS(I) NCH=MAX(NCH,LONG(MOTI)) CC(I,M3)=MOTI ENDDO C ==================================================== C LECTURE D'UN OBJET D'UN AUTRE TYPE QUE CEUX ATTENDUS C ==================================================== ELSE C ERREUR : On ne veut pas d'objet de type %m1:8 MOTERR = CHA8 CALL ERREUR(39) RETURN ENDIF GOTO 2 C +---------------------------------------------------------------+ C | | C | É C R I T U R E D A N S L E F I C H I E R | C | | C +---------------------------------------------------------------+ 900 CONTINUE IF (M.EQ.0) THEN C Aucun objet compatible n'a été trouvé MOTERR ='TABLE ' MOTERR( 9:16)='EVOLUTIO' MOTERR(17:24)='LISTREEL' MOTERR(25:32)='LISTENTI' MOTERR(33:40)='LISTMOTS' CALL ERREUR(471) RETURN ELSEIF (N.EQ.0) THEN WRITE(IOIMP,*) 'ATTENTION : il n''y a rien à sortir' CALL ERREUR(21) RETURN ELSE NCH=MIN(NCH,NCHMAX) ICOL=0 IF (NBCOL.EQ.0) NBCOL=M SEGINI,TRAV2 CHSEP=ACHAR(ICSEP) IF (NCH .LT. 10)THEN WRITE(MYFMT,'("(",I8,"(A",I1,",''",A1,"''))")') & NBCOL ,NCH ,CHSEP WRITE(MYFMT2,'("(A",I1,")")') NCH WRITE(FMTFLO,'("(1PE",I1,".",I2,"E3)")') NCH,NDIGIT ELSEIF(NCH .GE. 10 .AND. NCH .LT. 100)THEN WRITE(MYFMT,'("(",I8,"(A",I2,",''",A1,"''))")') & NBCOL ,NCH ,CHSEP WRITE(MYFMT2,'("(A",I2,")")') NCH WRITE(FMTFLO,'("(1PE",I2,".",I2,"E3)")') NCH,NDIGIT ELSEIF(NCH .GE. 100 .AND. NCH .LT. 1000)THEN WRITE(MYFMT,'("(",I8,"(A",I3,",''",A1,"''))")') & NBCOL ,NCH ,CHSEP WRITE(MYFMT2,'("(A",I3,")")') NCH WRITE(FMTFLO,'("(1PE",I3,".",I2,"E3)")') NCH,NDIGIT ELSE CALL ERREUR(5) ENDIF * write(*,*) 'MYFMT=',MYFMT,'MYFMT2=',MYFMT2,'FMTFLO=',FMTFLO 901 CONTINUE KK=MIN(ICOL+NBCOL,M) * Decalage a gauche du titre des colonnes, si leur largeur * depasse 12 caracteres DO K=ICOL+1,KK K1=K-ICOL CHARAC(K1)=TITCOL(K) ENDDO WRITE(UNIT=IOPER,FMT=MYFMT,IOSTAT=IOS,ERR=9999) & (CHARAC(I),I=1,KK-ICOL) IF (IOS .NE. 0) GOTO 9998 DO J=1,N DO I=1,KK-ICOL K=ICOL+I C on teste si le LISTREEL/LISTENTI/LISTMOTS associe a C cette colonne est bien de dim > ou= a J IF (LONCOL(K).GE.J) THEN IF (TYPCOL(K).EQ.'LISTREEL') THEN c WRITE(CHARAC(I),FMT='(1PE12.4E3)', WRITE(CHARAC(I),FMTFLO, & IOSTAT=IOS,ERR=9999) XX(J,NUMCOL(K)) ELSEIF (TYPCOL(K).EQ.'LISTENTI') THEN WRITE(CHARAC(I),FMT='(I12)', & IOSTAT=IOS,ERR=9999) II(J,NUMCOL(K)) ELSEIF (TYPCOL(K).EQ.'LISTMOTS') THEN WRITE(CHARAC(I),FMT=MYFMT2, & IOSTAT=IOS,ERR=9999) CC(J,NUMCOL(K)) ENDIF IF (IOS .NE. 0) GOTO 9998 ELSE CHARAC(I)=' ' 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,IOSTAT=IOS,ERR=9999) IF (IOS .NE. 0) GOTO 9998 WRITE(IOPER,996,IOSTAT=IOS,ERR=9999) IF (IOS .NE. 0) GOTO 9998 WRITE(IOPER,996,IOSTAT=IOS,ERR=9999) IF (IOS .NE. 0) GOTO 9998 GOTO 901 ENDIF ENDIF 996 FORMAT(A20) C 997 FORMAT(12(A12,';')) C 998 FORMAT(12(1PE12.5,';')) C Fermeture du fichier CLOSE(UNIT=IOPER) C Un peu de menage SEGSUP,TRAV RETURN C Sortie en ERREUR : IOS different de 0 9998 CONTINUE INTERR(1)=IOS INTERR(2)=IOPER LC1=LONG(FICEXC) MOTERR =FICEXC(1:LC1) CALL ERREUR(1067) RETURN C Sortie en ERREUR : Ecriture impossible dans l'unite 9999 CONTINUE INTERR(1)=IOPER LC1=LONG(FICEXC) MOTERR =FICEXC(1:LC1) CALL ERREUR(1066) RETURN END