Télécharger la plaquette Cast3M


fr en

Télécharger chired.eso

Retour à la liste

Numérotation des lignes : 

chired

  1. C CHIRED    SOURCE    CHAT      05/01/12    21:57:59     5004
  2.       SUBROUTINE CHIRED(IDSCHI,MTAB1,MTAB2,IZIADR,IADH,MLENT3,LIMP3)
  3.       IMPLICIT INTEGER(I-N)
  4.         IMPLICIT REAL*8 (A-H,O-Z)
  5. C------------------------------------------------------------------
  6. C
  7. C       CHARGEMENT DES TABLES IDEN ET REDOX
  8. C                MTAB1 = POINTEUR TABLE IDEN
  9. C                MTAB2 = POINTEUR TABLE REDOX
  10. C                      =  0 EN ENTREE
  11. C                MLENT3= POINTEUR DES COMPOSANTS IMMOBILES POUR
  12. C                        LES CONDITIONS AUX LIMITES DES TYPE 3
  13. C                        ( LU ET VERIFIE DANS CHICLM ,PEUT ETRE NUL)
  14. C                LIMP3 = POINTEUR DE LA LISTE DES ESPECES MISES EN
  15. C                        TYP3 PAR CLIM ( TAB1.CLIM.TYP3)
  16. C
  17. C------------------------------------------------------------------
  18. -INC SMTABLE
  19. -INC SMLENTI
  20. -INC SMLREEL
  21. -INC SMLMOTS
  22.  
  23. -INC PPARAM
  24. -INC CCOPTIO
  25.       SEGMENT IDSCHI
  26.            REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
  27.            INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
  28.            INTEGER IDECY(NYDIM),IONZ(NXDIM)
  29.            CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
  30.       ENDSEGMENT
  31.       SEGMENT IZIADR
  32.             INTEGER IADR(NCR)
  33.       ENDSEGMENT
  34.       SEGMENT IZRED
  35.             INTEGER ITAB(NCR,2)
  36.             REAL*8 ATAB(NCR,2)
  37.       ENDSEGMENT
  38.       SEGMENT IZREDI
  39.             INTEGER IRCR(MCR),ICR(LCR)
  40.       ENDSEGMENT
  41.       SEGMENT IZIMM
  42.             INTEGER IADE(NCE),IADC(NCC),IMM(NIMM)
  43.       ENDSEGMENT
  44.       SEGMENT IZRIAD
  45.             INTEGER IRAD(NIRA),ICONS(NXDIM)
  46.       ENDSEGMENT
  47.       SEGMENT IZSS
  48.             INTEGER ISOLU(NYDIM),ISURF(NYDIM)
  49.       ENDSEGMENT
  50.       CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR
  51. C
  52. C                    CHITRI1 CREE ET CHARGE IZIADR et IADH
  53.       IZRED=0
  54.       IZREDI=0
  55.       IF(IZIADR.NE.0)THEN
  56. C                     CHITRI CREE ET CHARGE IZRED
  57.             CALL CHITRI(IDSCHI,IZIADR,IZRED,IZREDI)
  58.       ENDIF
  59.       NXDIM=IDX(/1)
  60.       NYDIM=IDY(/1)
  61.       NZDIM=IDZ(/1)
  62.       NPDIM=IDP(/1)
  63.       JSOH=0
  64.       NCE=NN(3)
  65.       NCC=NN(3)
  66.       NIRA=NXDIM
  67.       NIMM=NXDIM
  68.       SEGINI IZIMM ,IZRIAD
  69. C                    ON VA METTRE DANS IRAD UN INDICE POUR CHAQUE
  70. C             COMPOSANT 3=IMMOBILE  2=REACTIFS 1=CONSERVATIF
  71.       CALL INITI(IRAD,NIRA,2)
  72. C TRI RELATION TYP3
  73.       NCE=0
  74.       NCC=0
  75.       JI=NN(1)+NN(2)+1
  76.       JM= NN(1)+NN(2)+NN(3)
  77.       DO 20  JJ=JI,JM
  78.          DO 10 J=1,NXDIM
  79.             IF (IDX(J).EQ.IDY(JJ)) THEN
  80.                NCE =NCE+1
  81.                IADE(NCE)=IDX(J)
  82.                IRAD(J)=3
  83.                GO TO 16
  84.             ENDIF
  85.    10     CONTINUE
  86.       NCC =NCC+1
  87.       IADC(NCC)=IDY(JJ)
  88.    16 CONTINUE
  89.    20 CONTINUE
  90. C-------------------------------------------------------------
  91. C      RECHERCHE DES COMPOSANTS NON TRANSPORTES
  92.       NIMM=0
  93.       IF(IADH.NE.0)THEN
  94.            NIMM=NIMM+1
  95.            IMM(NIMM)=60
  96.            CALL CHIADY(IDX,NXDIM,60,III)
  97.            IRAD(III)=3
  98.       ENDIF
  99.       IF(IZRED.NE.0)THEN
  100.             MCR=IRCR(/1)
  101.             CALL RSETI(IMM(NIMM+1),IRCR,MCR)
  102.             NIMM=NIMM+MCR
  103.             DO 25 J=1,MCR
  104.                  JJ=IRCR(J)
  105.                  CALL CHIADY(IDX,NXDIM,JJ,III)
  106.                  IRAD(III)=3
  107.    25       CONTINUE
  108.       ENDIF
  109.       IF(NCE.NE.0)THEN
  110.           CALL RSETI(IMM(NIMM+1),IADE,NCE)
  111.           NIMM=NIMM+NCE
  112.       ENDIF
  113.       JN=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)+1
  114.       JK=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)+NN(6)
  115.       NADSORB=0
  116.       DO 40 J=1,NXDIM
  117.          IF(IDX(J).EQ.80) NADSORB=NADSORB+1
  118. C        /TEST SUR LES SITES DE SURFACES/
  119.          IF (IDX(J).GE.90.AND.IDX(J).LE.96) THEN
  120. C
  121.            NADSORB=NADSORB+1
  122.            NIMM=NIMM+1
  123.            IMM(NIMM)=IDX(J)
  124.            IRAD(J)=3
  125.          ENDIF
  126.  
  127. C        /TEST SUR LES COMPOSANTS DE TYPE 6/
  128.  
  129.          DO 30 JJ=JN,JK
  130.             IF (IDX(J).EQ.IDY(JJ)) THEN
  131.             IF ( IDX(J).NE.99) THEN
  132.                NIMM=NIMM+1
  133.                IMM(NIMM)=IDX(J)
  134.                IRAD(J)=3
  135.             ENDIF
  136.             ENDIF
  137.   30     CONTINUE
  138.   40  CONTINUE
  139. C           PRISE EN COMPTE DES COMPOSANTS IMMOBILES DE CLIM TYP3
  140. C                ON A DEJA VERIFIE LEUR EXISTANCE
  141.       IF(MLENT3.GT.0)THEN
  142.       NL=MLENT3.LECT(/1)
  143.       MLENT1=LIMP3
  144.       SEGACT MLENT1
  145.       DO 35 J=1,NL
  146.       IDXT=MLENT3.LECT(J)
  147.       IDYT= MLENT1.LECT(J)
  148.       IF(IDXT.NE.IDYT)THEN
  149. C              ON VERIFIE QUE IDXT N'EST PAS DEJA IMMOBILE
  150.            CALL CHIADY(IMM,NIMM,IDXT,III)
  151.            IF(III.EQ.0)THEN
  152.                NIMM=NIMM+1
  153.                IMM(NIMM)=IDXT
  154.                CALL CHIADY(IDX,NXDIM,IDXT,JJ)
  155.                IRAD(JJ)=3
  156.            ELSE
  157. C              WRITE(6,*) ' LE COMPOSANT ',IDXT,' EST DEJA IMMOBILE'
  158.                INTERR(1)=IDXT
  159.                CALL ERREUR(778)
  160.                RETURN
  161.            ENDIF
  162.       ENDIF
  163.    35 CONTINUE
  164.       SEGDES MLENT1
  165.       ENDIF
  166. C   ----------------------------------------------------
  167. C
  168. C   RECHERCHE DU NOMBRE DE COMPOSANTS CONSERVATIFS: NCONS
  169.  
  170.       NCONS=0
  171.  
  172. C  TEST DE LA PRESENCE D'UN COMPOSANT DANS UNE ESPECE ADSORBEE
  173.  
  174.       IJ=NN(1)+1
  175.       IK=NN(1)+NN(2)+NN(3)+NN(4)
  176.       CALL CHIADY(IDX,NXDIM,90,JSOH)
  177.       DO 65 J=1,NXDIM
  178.       IF(JSOH.GT.0) THEN
  179.       DO 45 I=IJ,IK
  180.       IF (AA(I,JSOH).GT.0.D0.AND.ABS(AA(I,J)).GT.0.D0) GOTO 60
  181.   45  CONTINUE
  182.       ENDIF
  183.  
  184. C/ TEST DE LA PRESENCE D'UN COMPOSANT DANS UNE ESPECE SOLIDE
  185. C  DE TYPE 3, 4 OU 5.
  186.  
  187.          JI=NN(1)+NN(2)+1
  188.          IM=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)
  189.  
  190.          DO  50 I=JI,IM
  191.             IF (ABS(AA(I,J)).GT.0.D0) THEN
  192. *               WRITE(6,*) ' SOLIDE ',IDX(J)
  193.                 GO TO 60
  194.              ENDIF
  195.  
  196.   50     CONTINUE
  197.  
  198. ** ESPECE ECHANGEE
  199.          DO 55 I = IJ,IK
  200.             IF (ABS(AA(I,J)).GT.0.D0) THEN
  201.            IF(IDECY(I).NE.0) THEN
  202. C               WRITE(6,*) ' ECHANGE',IDX(J)
  203.                 GO TO 60
  204.            ENDIF
  205.            ENDIF
  206.    55 CONTINUE
  207.  
  208.          IF(IRAD(J).NE.3)THEN
  209.                NCONS=NCONS+1
  210.                ICONS(NCONS)=IDX(J)
  211.                IRAD(J)=1
  212. C        WRITE(6,*) 'ICONS(',N,'): ',IDX(J)
  213.          ENDIF
  214.   60  CONTINUE
  215.   65  CONTINUE
  216. C      --------------------------------------------------------
  217.       SEGACT MTAB1
  218.       IVALI=0
  219.       XVALI=0.D0
  220.       IRETI=0
  221.       IVALR=0
  222.       XVALR=0.D0
  223.       MTYPI='MOT     '
  224.       IF(NIMM.NE.0)THEN
  225.             JG=NIMM
  226.             SEGINI MLENTI
  227.             CALL RSETI(LECT,IMM,JG)
  228.             IRETR=MLENTI
  229.             MTYPR='LISTENTI'
  230.             CHARR='        '
  231.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'IMMO',.TRUE.,
  232.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  233.             SEGDES MLENTI
  234.       ENDIF
  235.       IF(NCONS.NE.0)THEN
  236.             JG=NCONS
  237.             SEGINI MLENTI
  238.             CALL RSETI(LECT,ICONS,JG)
  239.             IRETR=MLENTI
  240.             MTYPR='LISTENTI'
  241.             CHARR='        '
  242.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'PARF',.TRUE.,
  243.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  244.             SEGDES MLENTI
  245.       ENDIF
  246. C                           COMPOSANTS REACTIFS
  247.       JJG=NXDIM-NCONS-NIMM
  248.       IF(JJG.NE.0)THEN
  249.             JG=JJG
  250.             SEGINI MLENTI
  251.             I=0
  252.             DO 70 J=1,NXDIM
  253.                   IF(IRAD(J).EQ.2)THEN
  254.                         I=I+1
  255.                         LECT(I)=IDX(J)
  256.                   ENDIF
  257.    70       CONTINUE
  258.             IRETR=MLENTI
  259.             MTYPR='LISTENTI'
  260.             CHARR='        '
  261.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'REAC',.TRUE.,
  262.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  263.             SEGDES MLENTI
  264.       ENDIF
  265.       IF(NN(6).NE.0)THEN
  266. C                                  TYP6
  267.             JG=NN(6)
  268.             SEGINI MLENTI
  269.             JN=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)+1
  270.             CALL RSETI(LECT,IDY(JN),JG)
  271.             IRETR=MLENTI
  272.             MTYPR='LISTENTI'
  273.             CHARR='        '
  274.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'TYP6',.TRUE.,
  275.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  276.             SEGDES MLENTI
  277.             JGN=4
  278.             JGM=JG
  279.             SEGINI MLMOTS
  280.             DO 71 I=1,JG
  281.                   NLL=JN-1+I
  282.                   WRITE(MOTS(I),110)NLL
  283.    71       CONTINUE
  284.             IRETR=MLMOTS
  285.             MTYPR='LISTMOTS'
  286.             CHARR='        '
  287.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMTYP6',.TRUE.,
  288.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  289.             SEGDES MLMOTS
  290.       ENDIF
  291. C                                   TYP3
  292.       IF(NN(3).NE.0)THEN
  293.             JG=NN(3)
  294.             SEGINI MLENTI
  295.             JN=NN(1)+NN(2)+1
  296.             CALL RSETI(LECT,IDY(JN),JG)
  297.             IRETR=MLENTI
  298.             MTYPR='LISTENTI'
  299.             CHARR='        '
  300.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'TYP3',.TRUE.,
  301.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  302.             SEGDES MLENTI
  303.             JGN=4
  304.             JGM=JG
  305.             SEGINI MLMOTS
  306.             DO 72 I=1,JG
  307.                   NLL=JN-1+I
  308.                   WRITE(MOTS(I),110)NLL
  309.    72       CONTINUE
  310.             IRETR=MLMOTS
  311.             MTYPR='LISTMOTS'
  312.             CHARR='        '
  313.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMTYP3',.TRUE.,
  314.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  315.             SEGDES MLMOTS
  316.             IF(LIMP3.NE.0) THEN
  317.                   IRETR=LIMP3
  318.                   MTYPR='LISTENTI'
  319.                   CHARR='        '
  320.                   CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'IMP3',.TRUE.,
  321.      *            IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  322.             ENDIF
  323.       ENDIF
  324. C                                 PRECIPITES POTENTIELS
  325.       JJG=NN(4)+NN(5)
  326.       IF(JJG.NE.0)THEN
  327.             JG=JJG
  328.             SEGINI MLENTI
  329.             JN=NN(1)+NN(2)+NN(3)+1
  330.             CALL RSETI(LECT,IDY(JN),JG)
  331.             IRETR=MLENTI
  332.             MTYPR='LISTENTI'
  333.             CHARR='        '
  334.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'PRECI',.TRUE.,
  335.      *           IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  336.             SEGDES MLENTI
  337.             JGN=4
  338.             JGM=JG
  339.             SEGINI MLMOTS
  340.             DO 75 I=1,JG
  341.                NLL=JN-1+I
  342.                WRITE(MOTS(I),110)NLL
  343.  75         CONTINUE
  344.             IRETR=MLMOTS
  345.             MTYPR='LISTMOTS'
  346.             CHARR='        '
  347.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMPRECI',.TRUE.,
  348.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  349.             SEGDES MLMOTS
  350.       ENDIF
  351. C                                  SOLUTIONS SOLIDES
  352.       IF(NZDIM.NE.0)THEN
  353.          JG=NN(4)+NN(5)+NN(6)
  354.          SEGINI MLENTI
  355.          KS=0
  356.          JN=NN(1)+NN(2)+NN(3)+1
  357.          DO L=1,JG
  358.             NII=JN-1+L
  359.             IDYNI=IDY(NII)
  360.             CALL CHIADY(IDZ,NZDIM,IDYNI,IDNI)
  361.             IF(IDNI.NE.0)THEN
  362.                KS=KS+1
  363.                LECT(KS)=IDYNI
  364.             ENDIF
  365.          END DO
  366.          JG=KS
  367.          SEGADJ MLENTI
  368.          IRETR=MLENTI
  369.          MTYPR='LISTENTI'
  370.          CHARR='        '
  371.          CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'SOSO',.TRUE.,
  372.      *        IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  373.          SEGDES MLENTI
  374.          JGN=4
  375.          JGM=NN(4)+NN(5)+NN(6)
  376.          SEGINI MLMOTS
  377.          KM=0
  378.          DO I=1,JGM
  379.             NLL=JN-1+I
  380.             IDYNL=IDY(NLL)
  381.             CALL CHIADY(IDZ,NZDIM,IDYNL,IDNL)
  382.             IF(IDNL.NE.0)THEN
  383.                KM=KM+1
  384.                WRITE(MOTS(KM),110)NLL
  385.             ENDIF
  386.          END DO
  387.          JGM=KM
  388.          SEGADJ MLMOTS
  389.          IRETR=MLMOTS
  390.          MTYPR='LISTMOTS'
  391.          CHARR='        '
  392.          CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMSOSO',.TRUE.,
  393.      *        IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  394.          SEGDES MLMOTS
  395.       ENDIF
  396. C                                  POLES DE SOLUTIONS SOLIDES
  397.       IF(NZDIM.NE.0)THEN
  398.          IF(NPDIM.NE.0)THEN
  399.             JG=NN(6)
  400.             SEGINI MLENTI
  401.             KL=0
  402.             JN=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)+1
  403.             DO L=1,NN(6)
  404.                NII=JN-1+L
  405.                IDYNI=IDY(NII)
  406.                CALL CHIADY(IDP,NPDIM,IDYNI,IDNI)
  407.                IF(IDNI.NE.0)THEN
  408.                   DO K=1,NZDIM
  409.                      IF(FF(K,IDNI).NE.0.D0)THEN
  410.                         KL=KL+1
  411.                         LECT(KL)=IDYNI
  412.                      ENDIF
  413.                   END DO
  414.                ENDIF
  415.             END DO
  416.             JG=KL
  417.             SEGADJ MLENTI
  418.             IRETR=MLENTI
  419.             MTYPR='LISTENTI'
  420.             CHARR='        '
  421.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'POLE',.TRUE.,
  422.      *           IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  423.             SEGDES MLENTI
  424.             JGN=4
  425.             JGM=NN(6)
  426.             SEGINI MLMOTS
  427.             KM=0
  428.             DO I=1,NN(6)
  429.                NLL=JN-1+I
  430.                IDYNL=IDY(NLL)
  431.                CALL CHIADY(IDP,NPDIM,IDYNL,IDNL)
  432.                IF(IDNL.NE.0)THEN
  433.                   DO K=1,NZDIM
  434.                      IF(FF(K,IDNL).NE.0.D0)THEN
  435.                         KM=KM+1
  436.                         WRITE(MOTS(KM),110)NLL
  437.                      ENDIF
  438.                   END DO
  439.                ENDIF
  440.             END DO
  441.             JGM=KM
  442.             SEGADJ MLMOTS
  443.             IRETR=MLMOTS
  444.             MTYPR='LISTMOTS'
  445.             CHARR='        '
  446.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMPOLE',.TRUE.,
  447.      *           IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  448.             SEGDES MLMOTS
  449.          ENDIF
  450.       ENDIF
  451. C                                       TABLEAU IRAD
  452.       JG=NXDIM
  453.       SEGINI MLENTI
  454.       CALL RSETI(LECT,IRAD,JG)
  455.       IRETR=MLENTI
  456.       MTYPR='LISTENTI'
  457.       CHARR='        '
  458.       CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'COMP',.TRUE.,
  459.      *IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  460.       SEGDES MLENTI
  461.       SEGSUP IZIMM ,IZRIAD
  462. C                                    ESPECES SOLUBLES
  463. C                              ET ESPECES DE SURFACE
  464. C                  A COMPLETER POUR LES ESPECES DE SURFACE
  465.       SEGINI IZSS
  466.       N1=0
  467.       N3=0
  468.       JK=NN(1)+NN(2)
  469.       DO 85 I=1,JK
  470.           IF(IDECY(I).NE.0)THEN
  471.           N3=N3+1
  472.           ISURF(N3)=IDY(I)
  473.           GO TO 82
  474.           ENDIF
  475.           N1=N1+1
  476.           ISOLU(N1)=IDY(I)
  477.    82     CONTINUE
  478.    85 CONTINUE
  479.       IF ( N1.LT.1)THEN
  480. C     WRITE(6,*)' IL N Y A PAS D ESPECE EN SOLUTION '
  481.               CALL ERREUR(779)
  482.               RETURN
  483.       ENDIF
  484.       DO 88 I=1,NXDIM
  485.          IF(IDX(I).EQ.99)THEN
  486.                 CALL CHIADY(IDY,NYDIM,99,J)
  487.                 IF( J.GT.NN(1)+NN(2)+NN(3))THEN
  488.                         N1=N1+1
  489.                         ISOLU(N1)=99
  490.                  ENDIF
  491.          GO TO 90
  492.          ENDIF
  493.    88 CONTINUE
  494.    90 CONTINUE
  495. C                                ESPECES EN SOLUTION
  496.       JG=N1
  497.       SEGINI MLENTI
  498.       CALL RSETI(LECT,ISOLU,JG)
  499.       IRETR=MLENTI
  500.       MTYPR='LISTENTI'
  501.       CHARR='        '
  502.       CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'SOLU',.TRUE.,
  503.      *IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  504.       SEGDES MLENTI
  505.       JGN=4
  506.       JGM=JG
  507.       SEGINI MLMOTS
  508.       DO 92 I=1,JG
  509.             CALL CHIADY(IDY,NYDIM,ISOLU(I),NLL)
  510.             WRITE(MOTS(I),110)NLL
  511.    92 CONTINUE
  512.       IRETR=MLMOTS
  513.       MTYPR='LISTMOTS'
  514.       CHARR='        '
  515.       CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMSOLU',.TRUE.,
  516.      *IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  517.       SEGDES MLMOTS
  518. C                                ESPECES DE SURFACE
  519.       IF(N3.NE.0)THEN
  520.             JG=N3
  521.             SEGINI MLENTI
  522.             CALL RSETI(LECT,ISURF,JG)
  523.             IRETR=MLENTI
  524.             MTYPR='LISTENTI'
  525.             CHARR='        '
  526.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'SURF',.TRUE.,
  527.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  528.             SEGDES MLENTI
  529.             JGN=4
  530.             JGM=JG
  531.             SEGINI MLMOTS
  532.             DO 93 I=1,JG
  533.                   CALL CHIADY(IDY,NYDIM,ISURF(I),NLL)
  534.                   WRITE(MOTS(I),110)NLL
  535.    93       CONTINUE
  536.             IRETR=MLMOTS
  537.             MTYPR='LISTMOTS'
  538.             CHARR='        '
  539.             CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMSURF',.TRUE.,
  540.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  541.             SEGDES MLMOTS
  542.       ENDIF
  543.       SEGSUP IZSS
  544. C                                DESCRIPTION DES REDOX
  545.       IF(IZRED.NE.0)THEN
  546.             CALL CRTABL(MTAB2)
  547.             NCR=ITAB(/1)
  548.             JG=NCR
  549.             SEGINI MLENTI
  550.             if (jg.ne.0) CALL RSETI(LECT,ITAB(1,1),JG)
  551.             IRETR=MLENTI
  552.             MTYPR='LISTENTI'
  553.             CHARR='        '
  554.             CALL ECCTAB(MTAB2,MTYPI,IVALI,XVALI,'I1',.TRUE.,
  555.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  556.             SEGDES MLENTI
  557.             SEGINI MLENTI
  558.             if (jg.ne.0) CALL RSETI(LECT,ITAB(1,2),JG)
  559.             IRETR=MLENTI
  560.             MTYPR='LISTENTI'
  561.             CHARR='        '
  562.             CALL ECCTAB(MTAB2,MTYPI,IVALI,XVALI,'I2',.TRUE.,
  563.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  564.             SEGDES MLENTI
  565.             SEGINI MLREEL
  566.             if (jg.ne.0) CALL RSETD(PROG,ATAB(1,1),JG)
  567.             IRETR=MLREEL
  568.             MTYPR='LISTREEL'
  569.             CHARR='        '
  570.             CALL ECCTAB(MTAB2,MTYPI,IVALI,XVALI,'A1',.TRUE.,
  571.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  572.             SEGDES MLREEL
  573.             SEGINI MLREEL
  574.             if (jg.ne.0) CALL RSETD(PROG,ATAB(1,2),JG)
  575.             IRETR=MLREEL
  576.             MTYPR='LISTREEL'
  577.             CHARR='        '
  578.             CALL ECCTAB(MTAB2,MTYPI,IVALI,XVALI,'A2',.TRUE.,
  579.      *      IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR)
  580.             SEGDES MLREEL
  581.             SEGSUP IZIADR, IZRED,IZREDI
  582.       ENDIF
  583.   110 FORMAT('W',I3.3)
  584.       RETURN
  585.       END
  586.  
  587.  
  588.  
  589.  
  590.  
  591.  
  592.  
  593.  

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