Télécharger la plaquette Cast3M


fr en

Télécharger sorexc.eso

Retour à la liste

Numérotation des lignes : 

sorexc

  1. C SOREXC    SOURCE    CB215821  24/04/26    21:15:02     11924          
  2. C***********************************************************************
  3. C NOM         : sorexc.eso
  4. C DESCRIPTION : Sortie de données tabulaires au format CSV (Comma-
  5. C               Separated Values, pour Excel ou Matlab par exemple)
  6. C***********************************************************************
  7. C HISTORIQUE :  26/11/2003 : CHAT : version initiale
  8. C HISTORIQUE :  12/01/2010 : FANDEUR : deplacement du code de prsort.eso
  9. C                                      vers sorexc.eso
  10. C HISTORIQUE :  19/07/2011 : FANDEUR : correction anomalie 7035
  11. C HISTORIQUE :  07/06/2012 : JCARDO : ajout des options NCOL et SEPA
  12. C                                     + sortie de LISTENTI/LISTMOTS
  13. C                                     + ajout de l'extension CSV
  14. C                                     + fermeture du fichier
  15. C HISTORIQUE :
  16. C***********************************************************************
  17. C Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
  18. C en cas de modification de ce sous-programme afin de faciliter
  19. C la maintenance !
  20. C***********************************************************************
  21. C APPELÉ PAR : opérateur SORTir (prsort.eso)
  22. C***********************************************************************
  23. C ENTRÉES :: aucune
  24. C SORTIES :: aucune (sur fichier uniquement)
  25. C***********************************************************************
  26. C SYNTAXE (GIBIANE) :
  27. C
  28. C    SORT 'EXCE' OBJ1 (... OBJn) ('NCOL' ENTI1) ('SEPA' |'PVIR'|)
  29. C                                                       |'VIRG'|
  30. C                                                       |'ESPA'|
  31. C                                                       |'TABU'|
  32. C                                                       |'OBLI'|
  33. C
  34. C    avec OBJi = [ LENTIi | LREELi | LMOTSi | EVOLi | TABi ]
  35. C
  36. C***********************************************************************
  37.  
  38.       SUBROUTINE SOREXC
  39.  
  40.       IMPLICIT INTEGER(I-N)
  41.       IMPLICIT REAL*8(A-H,O-Z)
  42.  
  43.       EXTERNAL LONG
  44.  
  45.  
  46. -INC CCNOYAU
  47. -INC PPARAM
  48. -INC CCOPTIO
  49. -INC SMTABLE
  50. -INC SMLREEL
  51. -INC SMLENTI
  52. -INC SMLMOTS
  53. -INC SMEVOLL
  54.  
  55.       CHARACTER*1  CHA1
  56.       CHARACTER*8  CHA8
  57.       CHARACTER*(LOCHAI) MOTI
  58.       CHARACTER*20  MYFMT,MYFMT2,FMTFLO
  59.  
  60.       CHARACTER*(LOCHAI) FICEXC
  61.       LOGICAL ZOPEN
  62.  
  63. C Segment de travail contenant toutes les listes a ecrire dans le fichier CSV
  64. C M1 : nombre total de LISTREEL
  65. C M2 : nombre total de LISTENTI
  66. C M3 : nombre total de LISTMOTS
  67. C M  : nombre total de listes (M = M1 + M2 + M3)
  68.       SEGMENT TRAV
  69.           CHARACTER*(LOCHAI) TITCOL(M)
  70.           CHARACTER*8  TYPCOL(M)
  71.           INTEGER      NUMCOL(M),LONCOL(M)
  72.           REAL*8             XX(N,M1)
  73.           INTEGER            II(N,M2)
  74.           CHARACTER*(LONOM)  CC(N,M3)
  75.       ENDSEGMENT
  76.  
  77.       PARAMETER (NCHMAX=LOCHAI)
  78.       SEGMENT TRAV2
  79. *          CHARACTER*12 CHARAC(NBCOL)
  80.           CHARACTER*(LOCHAI) CHARAC(NBCOL)
  81.       ENDSEGMENT
  82.  
  83.       LOGICAL B_Z
  84.  
  85.       PARAMETER(NCLE=3)
  86.       CHARACTER*4 LCLE(NCLE)
  87.  
  88.       PARAMETER(NSEP=5)
  89.       INTEGER     LISEP(NSEP)
  90.       CHARACTER*4 LMSEP(NSEP)
  91.       CHARACTER*1 CHSEP
  92.  
  93.       PARAMETER(NTYP=3)
  94.       CHARACTER*8 LTYP(NTYP)
  95.       INTEGER ITYP(2)
  96.  
  97.  
  98.  
  99.  
  100.       DATA LCLE /'NCOL','SEPA','DIGI'/
  101.       DATA LMSEP /'TABU','VIRG','PVIR','ESPA','OBLI'/
  102.       DATA LISEP / 9    , 44   , 59   , 32   , 47   /
  103.       DATA LTYP /'LISTREEL','LISTENTI','LISTMOTS'/
  104.  
  105.  
  106.       M1=0
  107.       M2=0
  108.       M3=0
  109.       M=0
  110.       N=0
  111.       SEGINI,TRAV
  112.  
  113.  
  114. C     CB215821 : Dans les SORTIES on desactive toujours a mesure (pas de nouveau paradigme)
  115. C                Sinon on peut avoir des soucis de memoire
  116.  
  117.  
  118.  
  119. C     Ajout de l'extension au nom du fichier
  120.       INQUIRE(UNIT=IOPER,OPENED=ZOPEN)
  121.       IF (.NOT.ZOPEN) THEN
  122.           CALL ERREUR(-212)
  123.           WRITE(IOIMP,*) '(via OPTI "SORT")'
  124.           MOTERR ='CSV'
  125.           CALL ERREUR(705)
  126.           RETURN
  127.       ENDIF
  128.  
  129.       INQUIRE(UNIT=IOPER,NAME=FICEXC)
  130.       CLOSE(UNIT=IOPER,STATUS='KEEP',IOSTAT=IOST1,ERR=9999)
  131.       IF(IOST1 .NE. 0)GOTO 9998
  132.  
  133.       CALL LENCHA(FICEXC,LC)
  134.       IF ( (FICEXC(LC-3:LC).NE.'.csv') .AND.
  135.      &     (FICEXC(LC-3:LC).NE.'.CSV')      ) THEN
  136.           IF (LC+4.GT.LOCHAI) THEN
  137.               write(ioimp,*) 'CSV Filename too long with extension'
  138.               CALL ERREUR(1111)
  139.               RETURN
  140.           ENDIF
  141.           FICEXC(LC+1:LC+4)='.csv'
  142.       ENDIF
  143.       IOS=0
  144.       OPEN(UNIT=IOPER,STATUS='UNKNOWN',FILE=FICEXC(1:LONG(FICEXC)),
  145.      &     IOSTAT=IOS,FORM='FORMATTED')
  146.  
  147.  
  148.  
  149.  
  150. C     +---------------------------------------------------------------+
  151. C     |                                                               |
  152. C     |          L E C T U R E   D E S   M O T S   C L E F S          |
  153. C     |                                                               |
  154. C     +---------------------------------------------------------------+
  155.  
  156. C     Valeurs par défaut (nombre de colonnes et séparateur)
  157.       NBCOL=0
  158.       ICSEP=LISEP(3)
  159.       NDIGIT=4
  160.  1    CONTINUE
  161.       CALL LIRMOT(LCLE,NCLE,ICLE,0)
  162. C     Mot clef "NCOL"
  163.       IF (ICLE.EQ.1) THEN
  164.           CALL LIRENT(NBCOL,0,IRETOU)
  165.           IF (IRETOU.EQ.0) THEN
  166. C             ERREUR : Le mot-clé %m1:4 n'est pas suivi de la donnée correspondante
  167.               MOTERR =LCLE(ICLE)
  168.               CALL ERREUR(166)
  169.               RETURN
  170.           ENDIF
  171.           IF (NBCOL.LT.1) THEN
  172. C             ERREUR : On veut lire un entier supérieur ou égal à %i1 (on a lu : %i2)
  173.               INTERR(1)=1
  174.               INTERR(2)=NBCOL
  175.               CALL ERREUR(190)
  176.               RETURN
  177.           ENDIF
  178.           GOTO 1
  179. C     Mot clef "SEPA"
  180.       ELSEIF (ICLE.EQ.2) THEN
  181.           CALL LIRMOT(LMSEP,NSEP,ISEP,0)
  182.           IF (ISEP.EQ.0) THEN
  183. C             ERREUR : Le mot-clé %m1:4 n'est pas suivi de la donnée correspondante
  184.               MOTERR =LCLE(ICLE)
  185.               CALL ERREUR(166)
  186.               RETURN
  187.           ENDIF
  188.           ICSEP=LISEP(ISEP)
  189.           GOTO 1
  190. C     Mot clef "DIGIT"
  191.       ELSEIF (ICLE.EQ.3) THEN
  192.           CALL LIRENT(NDIGIT,0,IRETOU)
  193.           IF (IRETOU.EQ.0) THEN
  194. C             ERREUR : Le mot-clé %m1:4 n'est pas suivi de la donnée correspondante
  195.               MOTERR =LCLE(ICLE)
  196.               CALL ERREUR(166)
  197.               RETURN
  198.           ENDIF
  199.           IF (NDIGIT.LT.1) THEN
  200. C             ERREUR : On veut lire un entier supérieur ou égal à %i1 (on a lu : %i2)
  201.               INTERR(1)=1
  202.               INTERR(2)=NDIGIT
  203.               CALL ERREUR(190)
  204.               RETURN
  205.           ENDIF
  206.           GOTO 1
  207.       ENDIF
  208. *     il faut que NCH soit < ou = NCHMAX (cf. taille de CHARAC)
  209.       NCH=NDIGIT+8
  210.       NCH=MIN(NCH,NCHMAX)
  211. *      NDIGIT=NCH-8
  212.  
  213.  
  214.  
  215.  
  216.  
  217. C     +---------------------------------------------------------------+
  218. C     |                                                               |
  219. C     |           L E C T U R E   D E S   A R G U M E N T S           |
  220. C     |                     P R I N C I P A U X                       |
  221. 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  |
  222. C     |                                                               |
  223. C     +---------------------------------------------------------------+
  224.  
  225.   2   CONTINUE
  226.       CALL QUETYP(CHA8,0,IRETOU)
  227.       IF (IRETOU.EQ.0) GOTO 900
  228.  
  229. C     ============================
  230. C     LECTURE D'UN OBJET TABLE
  231. C     ============================
  232.       IF (CHA8.EQ.'TABLE') THEN
  233.           CALL LIROBJ('TABLE   ',MTABLE,1,IRETOU)
  234. C         Acquisition des LISTREEL, LISTENTI et LISTMOTS de la table
  235.           CALL ECROBJ('TABLE   ',MTABLE)
  236.           CALL INDETA
  237.           IF (IERR.NE.0) RETURN
  238.           CALL LIROBJ('TABLE   ',MTAB2,1,IRETOU)
  239.           IF (IERR.NE.0) RETURN
  240.  
  241. C         La TABLE doit etre reactivee apres INDETA
  242.           SEGACT,MTABLE,MTAB2
  243.  
  244.           M10=M1
  245.           M20=M2
  246.           M30=M3
  247.  
  248. C         Décompte
  249.           DO I=1,MLOTAB
  250.             IF (MTABTV(I)    .EQ.'LISTREEL') THEN
  251.               M1=M1+1
  252.               MLREEL=MTABIV(I)
  253.               SEGACT,MLREEL
  254.               N=MAX(N,PROG(/1))
  255.               SEGDES,MLREEL
  256.             ELSEIF (MTABTV(I).EQ.'LISTENTI') THEN
  257.               M2=M2+1
  258.               MLENTI=MTABIV(I)
  259.               SEGACT,MLENTI
  260.               N=MAX(N,LECT(/1))
  261.               SEGDES,MLENTI
  262.             ELSEIF (MTABTV(I).EQ.'LISTMOTS') THEN
  263.               M3=M3+1
  264.               MLMOTS=MTABIV(I)
  265.               SEGACT,MLMOTS
  266.               N=MAX(N,MOTS(/2))
  267.               SEGDES,MLMOTS
  268.             ELSE
  269. C             ERREUR : On ne veut pas d'objet de type %m1:8
  270.               MOTERR=MTABTV(I)
  271.               CALL ERREUR(39)
  272.               RETURN
  273.             ENDIF
  274.           ENDDO
  275.  
  276. C         Ajustement et copie des valeurs
  277.           M=M1+M2+M3
  278.           SEGADJ,TRAV
  279.           DO I=1,MLOTAB
  280.               IF (MTABTV(I).EQ.'LISTREEL') THEN
  281.                   M10=M10+1
  282.                   NUMCOL(M10+M20+M30)=M10
  283.                   MLREEL=MTABIV(I)
  284.                   SEGACT,MLREEL
  285.                   JMAX=PROG(/1)
  286.                   DO J=1,JMAX
  287.                       XX(J,M10)=PROG(J)
  288.                   ENDDO
  289.               ELSEIF (MTABTV(I).EQ.'LISTENTI') THEN
  290.                   M20=M20+1
  291.                   NUMCOL(M10+M20+M30)=M20
  292.                   MLENTI=MTABIV(I)
  293.                   SEGACT,MLENTI
  294.                   JMAX=LECT(/1)
  295.                   DO J=1,JMAX
  296.                       II(J,M20)=LECT(J)
  297.                   ENDDO
  298.               ELSEIF (MTABTV(I).EQ.'LISTMOTS') THEN
  299.                   M30=M30+1
  300.                   NUMCOL(M10+M20+M30)=M30
  301.                   MLMOTS=MTABIV(I)
  302.                   SEGACT,MLMOTS
  303.                   JMAX=MOTS(/2)
  304.                   DO J=1,JMAX
  305.                       MOTI=MOTS(J)
  306.                       NCH=MAX(NCH,LONG(MOTI))
  307.                       CC(J,M30)=MOTI
  308.                   ENDDO
  309.               ENDIF
  310.               M0=M10+M20+M30
  311.               TYPCOL(M0)=MTABTV(I)
  312.               LONCOL(M0)=JMAX
  313.               TITCOL(M0)='            '
  314.               IF (MTABTI(I).EQ.'MOT     ') THEN
  315.                   CALL ACCTAB(MTAB2,'ENTIER  ', I ,R_Z,CHA1,B_Z,I_Z,
  316.      &                              'MOT     ',I_Z,R_Z,MOTI,B_Z,I_Z)
  317.                   TITCOL(M0)=MOTI
  318.                   NCH=MAX(NCH,LONG(MOTI))
  319.               ENDIF
  320.           ENDDO
  321.           SEGSUP,MTAB2
  322.           SEGDES,MTABLE
  323.  
  324. C     ============================
  325. C     LECTURE D'UN OBJET EVOLUTION
  326. C     ============================
  327.       ELSEIF (CHA8.EQ.'EVOLUTIO') THEN
  328.           CALL LIROBJ('EVOLUTIO',MEVOLL,1,IRETOU)
  329.           IF (IERR.NE.0) RETURN
  330.           CALL ACTOBJ('EVOLUTIO',MEVOLL,1)
  331.           M10=M1
  332.           M20=M2
  333.           M30=M3
  334.  
  335. C         Decompte
  336.           DO I=1,IEVOLL(/1)
  337.               KEVOLL=IEVOLL(I)
  338.               CALL PLACE(LTYP,NTYP,ITYP(1),TYPX)
  339.               CALL PLACE(LTYP,NTYP,ITYP(2),TYPY)
  340.               IF (ITYP(1).GT.0.AND.ITYP(2).GT.0) THEN
  341.                  DO J=1,2
  342.                     IF (ITYP(J).EQ.1) THEN
  343.                        M1=M1+1
  344.                        IF (J.EQ.1) THEN
  345.                           MLREEL=IPROGX
  346.                        ELSE
  347.                           MLREEL=IPROGY
  348.                        ENDIF
  349.                        NN=PROG(/1)
  350.                     ELSEIF (ITYP(J).EQ.2) THEN
  351.                        M2=M2+1
  352.                        IF (J.EQ.1) THEN
  353.                           MLENTI=IPROGX
  354.                        ELSE
  355.                           MLENTI=IPROGY
  356.                        ENDIF
  357.                        NN=LECT(/1)
  358.                     ELSEIF (ITYP(J).EQ.3) THEN
  359.                        M3=M3+1
  360.                        IF (J.EQ.1) THEN
  361.                           MLMOTS=IPROGX
  362.                        ELSE
  363.                           MLMOTS=IPROGY
  364.                        ENDIF
  365.                        NN=MOTS(/2)
  366.                     ELSE
  367.                        CALL ERREUR(5)
  368.                        RETURN
  369.                     ENDIF
  370.                  ENDDO
  371.                  N=MAX(N,NN)
  372.               ENDIF
  373.           ENDDO
  374.  
  375. C         Ajustement et copie des valeurs
  376.           M=M1+M2+M3
  377.           SEGADJ,TRAV
  378.           DO I=1,IEVOLL(/1)
  379.              KEVOLL=IEVOLL(I)
  380.              CALL PLACE(LTYP,NTYP,ITYP(1),TYPX)
  381.              CALL PLACE(LTYP,NTYP,ITYP(2),TYPY)
  382.              IF (ITYP(1).GT.0.AND.ITYP(2).GT.0) THEN
  383.                 DO J=1,2
  384.                    IF (ITYP(J).EQ.1) THEN
  385.                       M10=M10+1
  386.                       NUMCOL(M10+M20+M30)=M10
  387.                       IF (J.EQ.1) THEN
  388.                          MLREEL=IPROGX
  389.                       ELSE
  390.                          MLREEL=IPROGY
  391.                       ENDIF
  392.                       KMAX=PROG(/1)
  393.                       DO K=1,KMAX
  394.                          XX(K,M10)=PROG(K)
  395.                       ENDDO
  396.                    ELSEIF (ITYP(J).EQ.2) THEN
  397.                       M20=M20+1
  398.                       NUMCOL(M10+M20+M30)=M20
  399.                       IF (J.EQ.1) THEN
  400.                          MLENTI=IPROGX
  401.                       ELSE
  402.                          MLENTI=IPROGY
  403.                       ENDIF
  404.                       KMAX=LECT(/1)
  405.                       DO K=1,KMAX
  406.                          II(K,M20)=LECT(K)
  407.                       ENDDO
  408.                    ELSEIF (ITYP(J).EQ.3) THEN
  409.                       M30=M30+1
  410.                       NUMCOL(M10+M20+M30)=M30
  411.                       IF (J.EQ.1) THEN
  412.                          MLMOTS=IPROGX
  413.                       ELSE
  414.                          MLMOTS=IPROGY
  415.                       ENDIF
  416.                       KMAX=MOTS(/2)
  417.                       DO K=1,KMAX
  418.                          MOTI=MOTS(K)
  419.                          NCH=MAX(NCH,LONG(MOTI))
  420.                          CC(K,M30)=MOTI
  421.                       ENDDO
  422.                    ELSE
  423.                       CALL ERREUR(5)
  424.                       RETURN
  425.                    ENDIF
  426.                    M0=M10+M20+M30
  427.                    TYPCOL(M0)=LTYP(ITYP(J))
  428.                    LONCOL(M0)=KMAX
  429.                    IF (J.EQ.1) THEN
  430.                       TITCOL(M0)  =NOMEVX
  431.                    ELSE
  432.                       TITCOL(M0)  =NOMEVY
  433.                    ENDIF
  434.                 ENDDO
  435.              ENDIF
  436.           ENDDO
  437.  
  438.  
  439. C     ===========================
  440. C     LECTURE D'UN OBJET LISTREEL
  441. C     ===========================
  442.       ELSEIF (CHA8.EQ.'LISTREEL') THEN
  443.           CALL LIROBJ('LISTREEL',MLREEL,1,IRETOU)
  444.           IF (IERR.NE.0) RETURN
  445.           M1=M1+1
  446.           SEGACT,MLREEL
  447.           N=MAX(N,PROG(/1))
  448.           M=M1+M2+M3
  449.           SEGADJ,TRAV
  450.           NUMCOL(M)=M1
  451.           TYPCOL(M)='LISTREEL'
  452.           LONCOL(M)=PROG(/1)
  453.           TITCOL(M)='            '
  454.           DO I=1,PROG(/1)
  455.               XX(I,M1)=PROG(I)
  456.           ENDDO
  457.  
  458. C     ===========================
  459. C     LECTURE D'UN OBJET LISTENTI
  460. C     ===========================
  461.       ELSEIF (CHA8.EQ.'LISTENTI') THEN
  462.           CALL LIROBJ('LISTENTI',MLENTI,1,IRETOU)
  463.           IF (IERR.NE.0) RETURN
  464.           M2=M2+1
  465.           SEGACT,MLENTI
  466.           N=MAX(N,LECT(/1))
  467.           M=M1+M2+M3
  468.           SEGADJ,TRAV
  469.           NUMCOL(M)=M2
  470.           TYPCOL(M)='LISTENTI'
  471.           LONCOL(M)=LECT(/1)
  472.           TITCOL(M)='            '
  473.           DO I=1,LECT(/1)
  474.               II(I,M2)=LECT(I)
  475.           ENDDO
  476.  
  477. C     ===========================
  478. C     LECTURE D'UN OBJET LISTMOTS
  479. C     ===========================
  480.       ELSEIF (CHA8.EQ.'LISTMOTS') THEN
  481.           CALL LIROBJ('LISTMOTS',MLMOTS,1,IRETOU)
  482.           IF (IERR.NE.0) RETURN
  483.           M3=M3+1
  484.           SEGACT,MLMOTS
  485.           N=MAX(N,MOTS(/2))
  486.           M=M1+M2+M3
  487.           SEGADJ,TRAV
  488.           NUMCOL(M)=M3
  489.           TYPCOL(M)='LISTMOTS'
  490.           LONCOL(M)=MOTS(/2)
  491.           TITCOL(M)='            '
  492.           DO I=1,MOTS(/2)
  493.               MOTI=MOTS(I)
  494.               NCH=MAX(NCH,LONG(MOTI))
  495.               CC(I,M3)=MOTI
  496.           ENDDO
  497.  
  498. C     ====================================================
  499. C     LECTURE D'UN OBJET D'UN AUTRE TYPE QUE CEUX ATTENDUS
  500. C     ====================================================
  501.       ELSE
  502. C       ERREUR : On ne veut pas d'objet de type %m1:8
  503.         MOTERR = CHA8
  504.         CALL ERREUR(39)
  505.         RETURN
  506.       ENDIF
  507.       GOTO 2
  508.  
  509.  
  510.  
  511.  
  512.  
  513. C     +---------------------------------------------------------------+
  514. C     |                                                               |
  515. C     |        É C R I T U R E   D A N S   L E   F I C H I E R        |
  516. C     |                                                               |
  517. C     +---------------------------------------------------------------+
  518.  
  519.  900  CONTINUE
  520.       IF (M.EQ.0) THEN
  521. C         Aucun objet compatible n'a été trouvé
  522.           MOTERR       ='TABLE   '
  523.           MOTERR( 9:16)='EVOLUTIO'
  524.           MOTERR(17:24)='LISTREEL'
  525.           MOTERR(25:32)='LISTENTI'
  526.           MOTERR(33:40)='LISTMOTS'
  527.           CALL ERREUR(471)
  528.           RETURN
  529.  
  530.       ELSEIF (N.EQ.0) THEN
  531.           WRITE(IOIMP,*) 'ATTENTION : il n''y a rien à sortir'
  532.           CALL ERREUR(21)
  533.           RETURN
  534.  
  535.       ELSE
  536.           NCH=MIN(NCH,NCHMAX)
  537.  
  538.           ICOL=0
  539.           IF (NBCOL.EQ.0) NBCOL=M
  540.           SEGINI,TRAV2
  541.  
  542.           CHSEP=ACHAR(ICSEP)
  543.           IF    (NCH .LT. 10)THEN
  544.             WRITE(MYFMT,'("(",I8,"(A",I1,",''",A1,"''))")')
  545.      &                        NBCOL  ,NCH     ,CHSEP
  546.             WRITE(MYFMT2,'("(A",I1,")")') NCH
  547.             WRITE(FMTFLO,'("(1PE",I1,".",I2,"E3)")') NCH,NDIGIT
  548.           ELSEIF(NCH .GE. 10 .AND. NCH .LT. 100)THEN
  549.             WRITE(MYFMT,'("(",I8,"(A",I2,",''",A1,"''))")')
  550.      &                        NBCOL  ,NCH     ,CHSEP
  551.             WRITE(MYFMT2,'("(A",I2,")")') NCH
  552.             WRITE(FMTFLO,'("(1PE",I2,".",I2,"E3)")') NCH,NDIGIT
  553.           ELSEIF(NCH .GE. 100 .AND. NCH .LT. 1000)THEN
  554.             WRITE(MYFMT,'("(",I8,"(A",I3,",''",A1,"''))")')
  555.      &                        NBCOL  ,NCH     ,CHSEP
  556.             WRITE(MYFMT2,'("(A",I3,")")') NCH
  557.             WRITE(FMTFLO,'("(1PE",I3,".",I2,"E3)")') NCH,NDIGIT
  558.           ELSE
  559.             CALL ERREUR(5)
  560.           ENDIF
  561. *          write(*,*) 'MYFMT=',MYFMT,'MYFMT2=',MYFMT2,'FMTFLO=',FMTFLO
  562.  
  563.  
  564.  901      CONTINUE
  565.           KK=MIN(ICOL+NBCOL,M)
  566.  
  567. *         Decalage a gauche du titre des colonnes, si leur largeur
  568. *         depasse 12 caracteres
  569.           DO K=ICOL+1,KK
  570.               K1=K-ICOL
  571.               CHARAC(K1)=TITCOL(K)
  572.           ENDDO
  573.  
  574.           WRITE(UNIT=IOPER,FMT=MYFMT,IOSTAT=IOS,ERR=9999)
  575.      &         (CHARAC(I),I=1,KK-ICOL)
  576.           IF (IOS .NE. 0) GOTO 9998
  577.           DO J=1,N
  578.               DO I=1,KK-ICOL
  579.                 K=ICOL+I
  580. C               on teste si le LISTREEL/LISTENTI/LISTMOTS associe a
  581. C               cette colonne est bien de dim > ou= a J
  582.                 IF (LONCOL(K).GE.J) THEN
  583.                   IF (TYPCOL(K).EQ.'LISTREEL') THEN
  584. c                      WRITE(CHARAC(I),FMT='(1PE12.4E3)',
  585.                       WRITE(CHARAC(I),FMTFLO,
  586.      &                      IOSTAT=IOS,ERR=9999) XX(J,NUMCOL(K))
  587.                   ELSEIF (TYPCOL(K).EQ.'LISTENTI') THEN
  588.                       WRITE(CHARAC(I),FMT='(I12)',
  589.      &                      IOSTAT=IOS,ERR=9999) II(J,NUMCOL(K))
  590.                   ELSEIF (TYPCOL(K).EQ.'LISTMOTS') THEN
  591.                       WRITE(CHARAC(I),FMT=MYFMT2,
  592.      &                      IOSTAT=IOS,ERR=9999) CC(J,NUMCOL(K))
  593.                   ENDIF
  594.                   IF (IOS .NE. 0) GOTO 9998
  595.  
  596.                 ELSE
  597.                   CHARAC(I)=' '
  598.                 ENDIF
  599.               ENDDO
  600.               WRITE(UNIT=IOPER,FMT=MYFMT) (CHARAC(I),I=1,KK-ICOL)
  601.           ENDDO
  602.  
  603.           ICOL=ICOL+NBCOL
  604.           IF (ICOL.LT.M) THEN
  605.               WRITE(IOPER,996,IOSTAT=IOS,ERR=9999)
  606.               IF (IOS .NE. 0) GOTO 9998
  607.               WRITE(IOPER,996,IOSTAT=IOS,ERR=9999)
  608.               IF (IOS .NE. 0) GOTO 9998
  609.               WRITE(IOPER,996,IOSTAT=IOS,ERR=9999)
  610.               IF (IOS .NE. 0) GOTO 9998
  611.               GOTO 901
  612.           ENDIF
  613.       ENDIF
  614.  
  615.  996  FORMAT(A20)
  616. C  997  FORMAT(12(A12,';'))
  617. C 998  FORMAT(12(1PE12.5,';'))
  618.  
  619.  
  620. C     Fermeture du fichier
  621.       CLOSE(UNIT=IOPER)
  622.  
  623. C     Un peu de menage
  624.       SEGSUP,TRAV
  625.       RETURN
  626.  
  627. C     Sortie en ERREUR : IOS different de 0
  628.  9998 CONTINUE
  629.       INTERR(1)=IOS
  630.       INTERR(2)=IOPER
  631.       LC1=LONG(FICEXC)
  632.       MOTERR =FICEXC(1:LC1)
  633.       CALL ERREUR(1067)
  634.       RETURN
  635.  
  636. C     Sortie en ERREUR : Ecriture impossible dans l'unite
  637.  9999 CONTINUE
  638.       INTERR(1)=IOPER
  639.       LC1=LONG(FICEXC)
  640.       MOTERR =FICEXC(1:LC1)
  641.       CALL ERREUR(1066)
  642.       RETURN
  643.  
  644.       END
  645.  
  646.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales