Télécharger la plaquette Cast3M


fr en

Télécharger chimi1.eso

Retour à la liste

Numérotation des lignes : 

chimi1

  1. C CHIMI1    SOURCE    OF166741  23/08/04    21:15:03     11718          
  2.       SUBROUTINE CHIMI1
  3. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  4. C
  5. C               OPERATEUR CHI1
  6. C
  7. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  8.       IMPLICIT INTEGER(I-N)
  9.       IMPLICIT REAL*8(A-H,O-Z)
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC SMTABLE
  14. -INC SMLENTI
  15.       SEGMENT IDSCHI
  16.            REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
  17.            INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
  18.            INTEGER IDECY(NYDIM),IONZ(NXDIM)
  19.            CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
  20.       ENDSEGMENT
  21.       SEGMENT IZIADR
  22.             INTEGER IADR(NCR)
  23.       ENDSEGMENT
  24.       POINTEUR MLIDEN.MLENTI
  25.       CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR
  26.       CHARACTER*(LOCHAI) CHARB,CHARL,CHART
  27.       LOGICAL LTEMPE,LOGIR,LOGRE
  28. C
  29.       MLENT3=0
  30.       LIMP3=0
  31.       IRETOU=0
  32.       MTAB1=0
  33.       CALL LIROBJ('TABLE',MTAB1,0,IRETOU)
  34.       IF(IRETOU.EQ.0)THEN
  35.       CALL LIROBJ('OBJET',MTAB1,1,IRETOU)
  36. *      write(6,*)' mtab1 ',mtab1
  37.       IF(IRETOU.EQ.0)RETURN
  38.       ENDIF
  39. C                          ON LIT LES ADRESSES DE LA BASE DE DONNEE
  40.       IOCHI1=0
  41.       IOCHI2=0
  42.       IOCHI3=0
  43.       LBB=0
  44.       LBL=0
  45.       LBT=0
  46.       DO 10 I=1,3
  47.           CALL LIRCHA(CHARR,0,IRETOU)
  48.           IF(IRETOU.EQ.0)GO TO 11
  49.           IF(CHARR(1:4).EQ.'COMP')THEN
  50.               CALL LIRENT(IVAL,0,IRETOU)
  51.               IF(IRETOU.EQ.1)IOCHI1=IVAL
  52.               CALL LIRCHA(CHARB,0,LBB)
  53.           ELSEIF(CHARR(1:4).EQ.'LOGK')THEN
  54.               CALL LIRENT(IVAL,0,IRETOU)
  55.               IF(IRETOU.EQ.1)IOCHI2=IVAL
  56.               CALL LIRCHA(CHARL,0,LBL)
  57.           ELSEIF(CHARR(1:4).EQ.'ENTH')THEN
  58.               CALL LIRENT(IVAL,0,IRETOU)
  59.               IF(IRETOU.EQ.1)IOCHI3=IVAL
  60.               CALL LIRCHA(CHART,0,LBT)
  61.           ELSE
  62.               MOTERR(1:6)='COMP  '
  63.               CALL ERREUR(396)
  64.           ENDIF
  65.           IF (IERR.NE.0) RETURN
  66.    10 CONTINUE
  67.    11 CONTINUE
  68.       IF(IOCHI1.EQ.0)THEN
  69.           IF(LBB.EQ.0)THEN
  70.               MOTERR(1:4)='COMP'
  71.               CALL ERREUR(396)
  72.               RETURN
  73.           ELSE
  74.               IOCHI1=80
  75.           ENDIF
  76.       ENDIF
  77.       IF(LBB.NE.0)THEN
  78.             CALL CHIDBD(IOCHI1,CHARB)
  79.             IF (IERR.NE.0) RETURN
  80.       ENDIF
  81.       IF(LBL.NE.0)THEN
  82.             IF(CHARB(1:LBB).EQ.CHARL(1:LBL))THEN
  83.                   IOCHI2=IOCHI1
  84.             ELSE
  85.                   IF(IOCHI2.EQ.0)IOCHI2=IOCHI1+1
  86.                   CALL CHIDBD(IOCHI2,CHARL)
  87.                   IF (IERR.NE.0) RETURN
  88.             ENDIF
  89.       ELSE
  90.             IF(IOCHI2.EQ.0)IOCHI2=IOCHI1
  91.       ENDIF
  92.       IF(LBT.NE.0)THEN
  93.             IF(CHART(1:LBT).EQ.CHARL(1:LBL))THEN
  94.                   IOCHI3=IOCHI2
  95.             ELSE
  96.                   IF(IOCHI3.EQ.0)IOCHI3=IOCHI2+1
  97.                   CALL CHIDBD(IOCHI3,CHART)
  98.                   IF (IERR.NE.0) RETURN
  99.             ENDIF
  100.       ELSE
  101.       ENDIF
  102. C
  103.       SEGACT MTAB1
  104.       IVALI=1
  105.       XVALI=0.D0
  106.       IRETI=0
  107.       IVALR=0
  108.       XVALR=0.D0
  109.       IRETR=0
  110.       MTYPI='MOT     '
  111.       MTYPR='LISTENTI'
  112.       CHARR='        '
  113.       CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'IDEN',.TRUE.,IRETI,
  114.      * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  115.       IF(IERR.NE.0)RETURN
  116.       MLIDEN=IRETR
  117.       SEGACT MLIDEN
  118.       NLIDEN=MLIDEN.LECT(/1)
  119.       SEGDES MLIDEN
  120.       LXMX=0
  121.       IVALI=1
  122.       XVALI=0.D0
  123.       IRETI=0
  124.       IVALR=0
  125.       XVALR=0.D0
  126.       IRETR=0
  127.       MTYPI='MOT     '
  128.       MTYPR='        '
  129.       CHARR='        '
  130.       CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'CHXMX',.TRUE.,IRETI,
  131.      * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  132.       IF(MTYPR.NE.'        ')THEN
  133.             IF(MTYPR.NE.'LISTENTI')THEN
  134.                  MOTERR(1:11)='CHXMX      '
  135.                  MOTERR(12:20)='LISTENTI'
  136.                  CALL ERREUR(627)
  137.                  RETURN
  138.             ENDIF
  139.             LXMX=IRETR
  140.       ENDIF
  141.       LBDD=0
  142.       IVALI=1
  143.       XVALI=0.D0
  144.       IRETI=0
  145.       IVALR=0
  146.       XVALR=0.D0
  147.       IRETR=0
  148.       MTYPI='MOT     '
  149.       MTYPR='        '
  150.       CHARR='        '
  151.       CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'BDD',.TRUE.,IRETI,
  152.      * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  153.       IF(MTYPR.NE.'        ')THEN
  154.             IF(CHARR.EQ.'MINEQL  ')THEN
  155.                  LBDD=0
  156.             ELSEIF(CHARR.EQ.'STRASBG  ')THEN
  157.                  LBDD=1
  158.             ELSE
  159.                  MOTERR(1:11)='BDD        '
  160.                  MOTERR(12:20)='CONNU   '
  161.                  CALL ERREUR(627)
  162.                  RETURN
  163.             ENDIF
  164.       ENDIF
  165.       CALL CHILEC(LBDD,MLIDEN,LXMX,IDSCHI,IOCHI1,IOCHI2)
  166.       IF(IERR.NE.0)RETURN
  167. C                  ON GARDE LA LISTE DES ESPECES SIMPLES DE TYPE 3
  168.       CALL CHITR1(IDSCHI,IZIADR,IADH,LBDD)
  169. *      WRITE(6,*)'CHILEC et CHITRI faits'
  170. C
  171.       IVALI=0
  172.       XVALI=0.D0
  173.       IRETI=0
  174.       IVALR=0
  175.       XVALR=0.D0
  176.       IRETR=0
  177.       MTYPI='MOT     '
  178.       MTYPR='        '
  179.       CHARR='        '
  180.       NVCOMP=0
  181.       CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'NVCOMP',.TRUE.,IRETI,
  182.      * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  183.       IF(MTYPR.NE.'        ')THEN
  184.             IF((MTYPR.NE.'TABLE   ').AND.(MTYPR.NE.'OBJET   '))THEN
  185.                  MOTERR(1:11)='NVCOMP     '
  186.                  MOTERR(12:20)='TABLE   '
  187.                  CALL ERREUR(627)
  188.                  RETURN
  189.             ENDIF
  190.       NVCOMP=IRETR
  191.       CALL CHICMP(NVCOMP,IDSCHI)
  192.       IF(IERR.NE.0)RETURN
  193.       ENDIF
  194.       IVALI=0
  195.       XVALI=0.D0
  196.       IRETI=0
  197.       IVALR=0
  198.       XVALR=0.D0
  199.       IRETR=0
  200.       MTYPI='MOT     '
  201.       MTYPR='        '
  202.       CHARR='        '
  203.       NVESP=0
  204.       CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'NVESP',.TRUE.,IRETI,
  205.      * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  206.       IF(MTYPR.NE.'        ')THEN
  207.             IF((MTYPR.NE.'TABLE   ').AND.(MTYPR.NE.'OBJET   '))THEN
  208.                  MOTERR(1:11)='NVESP      '
  209.                  MOTERR(12:20)='TABLE   '
  210.                  CALL ERREUR(627)
  211.                  RETURN
  212.             ENDIF
  213.       NVESP=IRETR
  214.       CALL CHIESP(NVESP,IDSCHI)
  215.       ENDIF
  216.       IVALI=0
  217.       XVALI=0.D0
  218.       IRETI=0
  219.       IVALR=0
  220.       XVALR=0.D0
  221.       IRETR=0
  222.       MTYPI='MOT     '
  223.       MTYPR='        '
  224.       CHARR='        '
  225.       NVSOSO=0
  226. *      write(6,*)' mtab1 ',mtab1
  227.       CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'NVSOSO',.TRUE.,IRETI,
  228.      * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  229.       IF(MTYPR.NE.'        ')THEN
  230.             IF((MTYPR.NE.'TABLE   ').AND.(MTYPR.NE.'OBJET   '))THEN
  231.                  MOTERR(1:11)='NVSOSO     '
  232.                  MOTERR(12:20)='TABLE   '
  233.                  CALL ERREUR(627)
  234.                  RETURN
  235.             ENDIF
  236.       NVSOSO=IRETR
  237. *      WRITE(6,*)'CHIMI1, NVSOSO=',NVSOSO
  238.       CALL CHISOL(NVSOSO,IDSCHI)
  239.       ENDIF
  240.       IVALI=0
  241.       XVALI=0.D0
  242.       IRETI=0
  243.       IVALR=0
  244.       XVALR=0.D0
  245.       IRETR=0
  246.       MTYPI='MOT     '
  247.       MTYPR='        '
  248.       CHARR='LISTENTI'
  249.       IZECH=0
  250.       CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'ECHANGE',.TRUE.,IRETI,
  251.      * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  252.       IF(MTYPR.NE.'        ')THEN
  253.       IZECH=IRETR
  254.       CALL CHIECH(IZECH,IDSCHI)
  255.       ENDIF
  256.       IVALI=0
  257.       XVALI=0.D0
  258.       IRETI=0
  259.       IVALR=0
  260.       XVALR=0.D0
  261.       IRETR=0
  262.       MTYPI='MOT     '
  263.       MTYPR='        '
  264.       CHARR='TABLE'
  265.       ICLIM=0
  266.       MLENT=0
  267.       CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'CLIM',.TRUE.,IRETI,
  268.      * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  269.       IF(MTYPR.NE.'        ')THEN
  270.       ICLIM=IRETR
  271.       CALL CHICLM(ICLIM,IDSCHI,IZIADR,MLENT3,LIMP3)
  272.       IF(IERR.NE.0)RETURN
  273.       ENDIF
  274.       LTEMPE=.FALSE.
  275.       LTMP=1
  276.       LOGIR=.TRUE.
  277.       IVALI=1
  278.       XVALI=0.D0
  279.       IRETI=0
  280.       IVALR=0
  281.       XVALR=0.D0
  282.       IRETR=0
  283.       MTYPI='MOT     '
  284.       MTYPR='        '
  285.       CHARR='        '
  286.       CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'TEMPERATURE',.TRUE.,IRETI,
  287.      * MTYPR,IVALR,XVALR,CHARR,LOGIR,IRETR)
  288.       IF(MTYPR.NE.'        ')THEN
  289.             IF(CHARR.EQ.'OUI')THEN
  290.                    LTEMPE=.TRUE.
  291.             ELSEIF(CHARR.EQ.'NON')THEN
  292.                    LTEMPE=.FALSE.
  293.             ELSEIF(MTYPR.EQ.'ENTIER  ')THEN
  294.                    LTEMPE=.TRUE.
  295.                    LTMP=IVALR
  296.                    IF((LTMP.NE.1).AND.(LTMP.NE.2))THEN
  297.                MOTERR(1:40)='**********************TEMPERATURE       '
  298.                        CALL ERREUR(-301)
  299.                        CALL ERREUR(21)
  300.                        RETURN
  301.                    ENDIF
  302.             ELSE
  303.                MOTERR(1:40)='**********************TEMPERATURE       '
  304.                    CALL ERREUR(-301)
  305.                    CALL ERREUR(21)
  306.                    RETURN
  307.             ENDIF
  308.       ENDIF
  309.       IF(LTEMPE)THEN
  310.           IF(IOCHI3.EQ.0)IOCHI3=IOCHI2
  311.       ENDIF
  312.       SEGDES MTAB1
  313. C                   ON CREE LA TABLE RESULTAT
  314.       CALL CRTABL(MTAB3)
  315.       CALL ECCTAB(MTAB3,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,'MOT',
  316.      *  0,0.D0,'CHIMI1',.TRUE.,0)
  317. C                      TABLE DESCHI (DESCRIPTION)
  318.       CALL CRTABL(MTAB2)
  319.       CALL CHIDES(MTAB2,IDSCHI)
  320.       CHARR='        '
  321.       CALL ECCTAB(MTAB3,'MOT',0,0.D0,'DESCHI',.TRUE.,0,'TABLE',
  322.      *  0,0.D0,CHARR,.TRUE.,MTAB2)
  323.       SEGDES MTAB2
  324.       MTAB2=0
  325.       CALL CRTABL(MTAB1)
  326.       CALL CHIRED(IDSCHI,MTAB1,MTAB2,IZIADR,IADH,MLENT3,LIMP3)
  327.       IF(MLENT3.NE.0)THEN
  328.                     SEGDES MLENT3
  329.       ENDIF
  330.       IF(IERR.NE.0)RETURN
  331.       CHARR='        '
  332.       CALL ECCTAB(MTAB3,'MOT',0,0.D0,'IDEN',.TRUE.,0,'TABLE',
  333.      *  0,0.D0,CHARR,.TRUE.,MTAB1)
  334.       SEGDES MTAB1
  335.       IF(MTAB2.NE.0)THEN
  336.             CHARR='        '
  337.             CALL ECCTAB(MTAB3,'MOT',0,0.D0,'REDOX',.TRUE.,0,'TABLE',
  338.      *        0,0.D0,CHARR,.TRUE.,MTAB2)
  339.             SEGDES MTAB2
  340.       ENDIF
  341.       IF(LTEMPE)THEN
  342.             CALL CRTABL(MTAB1)
  343.             CALL CHITET(MTAB1,IDSCHI,LBDD,IOCHI3,LTMP)
  344.             CHARR='        '
  345.             CALL ECCTAB(MTAB3,'MOT',0,0.D0,'TEMPE',.TRUE.,0,'TABLE',
  346.      *        0,0.D0,CHARR,.TRUE.,MTAB1)
  347.             SEGDES MTAB1
  348.       ENDIF
  349.       REWIND(UNIT=IOCHI1)
  350.       CLOSE(UNIT=IOCHI1)
  351.       IF(IOCHI1.NE.IOCHI2)THEN
  352.             REWIND(UNIT=IOCHI2)
  353.             CLOSE(UNIT=IOCHI2)
  354.       ENDIF
  355.       IF((IOCHI3.NE.IOCHI2).AND.LTEMPE)THEN
  356.             REWIND(UNIT=IOCHI3)
  357.             CLOSE(UNIT=IOCHI3)
  358.       ENDIF
  359.       CALL ECROBJ('TABLE',MTAB3)
  360.       SEGDES MTAB3
  361.       SEGSUP IDSCHI
  362. C      RETURN
  363.       END
  364.  
  365.  
  366.  

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