Télécharger la plaquette Cast3M


fr en

Télécharger chinp.eso

Retour à la liste

Numérotation des lignes : 

chinp

  1. C CHINP     SOURCE    OF166741  23/10/16    21:15:04     11754          
  2.       SUBROUTINE CHINP(IDSCHI,LXMX,IOCHI1,IOCHI2)
  3. C
  4. C=======================================================================
  5. C               sp issu de TRIOEF
  6. C
  7. C
  8. C
  9. C LECTURE DE LA B.D.D. THERMODYNAMIQUE MINEQL
  10. C
  11. C======================================================================
  12.       IMPLICIT INTEGER(I-N)
  13.       IMPLICIT REAL*8(A-H,O-Z)
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17.  
  18. -INC SMLENTI
  19.       POINTEUR MLXMX.MLENTI
  20.  
  21.       SEGMENT IDSCHI
  22.            REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
  23.            INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
  24.            INTEGER IDECY(NYDIM),IONZ(NXDIM)
  25.            CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
  26.       ENDSEGMENT
  27.  
  28.       SEGMENT IZCOMP
  29.         CHARACTER*8 NAM(NXD)
  30.         INTEGER ION(NXD),IADXT(NXD)
  31.       ENDSEGMENT
  32.  
  33.       DIMENSION IAT(4),IDT(4)
  34.  
  35.       NXD=200
  36.       SEGINI IZCOMP
  37. C INITIALIZE ADDRESS
  38.       DO J=1,NXD
  39.         NAM(J)  ='        '
  40.         ION(J)  =0
  41.         IADXT(J)=0
  42.       ENDDO
  43.  
  44. c*dbg      write(ioimp,*) 'CHINP debut lecture',iochi1,iochi2
  45. CBRUNO
  46.       I_Z=0
  47.       READ(IOCHI1,520,END=910) (NAM(J),J=1,NXD)
  48.       I_Z=1
  49.  910  CONTINUE
  50.       IF (I_Z.EQ.0) THEN
  51.         write(ioimp,*) 'Fin du fichier IOCHI1 atteinte',J
  52.       ENDIF
  53. c*dbg      write(ioimp,*) 'Fichier IOCHI1'
  54. c*dbg      write(ioimp,*) ('='//NAM(J)//'=',J=1,NXD)
  55.  
  56.       READ(IOCHI1,530) (ION(J),J=1,NXD)
  57.  
  58. C      WRITE(ioimp,*)'chinp COMPO LU '
  59.  
  60. C INITIALIZE NN
  61.       NXDIM=IDX(/1)
  62.       NYDIM=IDY(/1)
  63.       NZDIM=IDZ(/1)
  64.       NPDIM=IDP(/1)
  65.  
  66.       NNN=NXDIM
  67. C      WRITE(ioimp,*)'chinp NNN',NNN
  68.  
  69. C INPUT BASIS IN A MATRIX
  70.       DO I=1,NNN
  71.        IDXT=IDX(I)
  72.        IF(IDXT.GT.NXD)THEN
  73. C              WRITE(6,*)'IDXT',IDXT
  74. C              WRITE(6,*)'NDX',NDX
  75.               INTERR(1)=IDXT
  76.               CALL ERREUR(781)
  77.               GO TO 500
  78.        ENDIF
  79. CRUNO
  80.        NAME(I)='                                  '
  81.        NAME(I)(1:8)=NAM(IDXT)
  82.        IONZ(I)=ION(IDXT)
  83. C        IF (IDX(I).EQ.90) JSOH=I
  84.        IADXT(IDXT)=I
  85. C        X(I)=10.**GX(I)
  86.        IDY(I)=IDX(I)
  87.        AA(I,I)=1.0D0
  88.        GK(I)=0.0D0
  89.       ENDDO
  90.  
  91. c*dbg      WRITE(ioimp,*)'chinp COMPOSANT SURFACE '
  92.       NN(1)=NNN
  93.  
  94. C ***************** LECTURE DES DONNEES THERMODYNAMIQUES
  95.  
  96.       I=NN(1)
  97.       DO 400 L=2,6
  98. c*dbg        WRITE(ioimp,*)' TYPE ',L
  99.          I0=I
  100.          READ(IOCHI2,510) IN
  101. c*dbg           WRITE(ioimp,*)'chinp NOMBRE ESPECE ' ,IN
  102.          IF(IN.EQ.0) GO TO 400
  103.          DO 300 II=1,IN
  104.             READ(IOCHI2,510) IDYT,GKT,(IDT(J),IAT(J),J=1,4)
  105.             DO 310 J=1,4
  106.                JTEST=IDT(J)
  107.                IF(JTEST.EQ.0) GO TO 310
  108.                IF(IADXT(JTEST).EQ.0) GO TO 300
  109. 310         CONTINUE
  110.  
  111.             I=I+1
  112.             IF (I.GT.NYDIM) THEN
  113.                  MOTERR(1:8)=' CHXMX '
  114.                  MOTERR(9:16)='SUITENTI'
  115.                  CALL ERREUR(787)
  116.                  RETURN
  117.             ENDIF
  118.             IDY(I)=IDYT
  119.             GK(I)=GKT
  120.  
  121. C       WRITE(ioimp,*)'chinp ESPÈCE',IDY(I)
  122.             DO 320 J=1,4
  123.                JTEST=IDT(J)
  124. C              IF (IDT(J).EQ.90) N3=N3+1
  125.                IF(JTEST.EQ.0) GO TO 320
  126.                IADTJT=IADXT(JTEST)
  127.                AA(I,IADTJT)=IAT(J)
  128. C       WRITE(6,*)'chinp   COMP',IDT(J),AA(I,IADTJT)
  129. 320         CONTINUE
  130. 300      CONTINUE
  131.  
  132. CMONI---------------LE 10 SEPT 91----------------------------
  133.       IF (L.EQ.5) THEN
  134.        NOUVI=0
  135. *        WRITE(6,*)' NMXCH ',NMXCH
  136.        IF (LXMX.EQ.0) GOTO 270
  137.        MLXMX=LXMX
  138.        SEGACT MLXMX
  139.        NMXCH=MLXMX.LECT(/1)
  140.  
  141. CPATBOS------------------------------------------------------
  142. C         MISE EN IDP DES SOLIDES CHOISIS PAR L UTILISATEUR
  143.        NPDIM=NMXCH
  144.        SEGADJ IDSCHI
  145.        CALL RSETI(IDP,MLXMX.LECT,NPDIM)
  146.        IN5=I
  147. C
  148. *-----------------***------MONI------***-------------------------------
  149. *   CES MODIFS PERMETTENT DE FAIRE UN CHOIX DES MINERAUX A PRENDRE
  150. *   EN COMPTE;( AVEC MINEQL IL EXISTE UNE FACON BIEN SIMPLE :
  151. *             METTRE, DANS LE MAIN, TOUTES LES ESPECES DE TYPE 5
  152. *   (MINERAL DISSOUS QUI PEUT PRECIPITER S'IL ARRIVE A SATURATION),
  153. *   EN TYPE 6 :
  154. *              NN(6)=NN(5)+NN(6)
  155. *              NN(5)=0
  156. *     PUIS, SELECTIONNER EN TYPE 5 LES MINERAUX CHOISIS :
  157. *      EX:
  158. *              I5=5
  159. *              I6=6
  160. *              CALL EXTYP(02231,I6,I5)
  161. **********************************************************************
  162.  
  163. *C     RECHERCHE DES MINERAUX NON PRIS EN COMPTE
  164.           III=I
  165. C ---
  166.           DO 266 ICHOI=I0+1,III
  167.           DO 267 NM0=1,NMXCH
  168.             IF (IDY(ICHOI).EQ.(MLXMX.LECT(NM0))) GOTO 269
  169.   267     CONTINUE
  170.  
  171.           IDY(ICHOI)=0
  172.           GK(ICHOI)=0.D0
  173. CBRUNO
  174.        DO 210 JK=1,NNN
  175.            AA(ICHOI,JK)=0.D0
  176.  210   CONTINUE
  177.  
  178.           I=I-1
  179.           GOTO 265
  180.  
  181.   269     NOUVI=NOUVI+1
  182.           IDY(I0+NOUVI)=IDY(ICHOI)
  183.           GK(I0+NOUVI)=GK(ICHOI)
  184. CBRUNO
  185.        DO JK=1,NNN
  186.            AA(I0+NOUVI,JK)=AA(ICHOI,JK)
  187.            IF(ICHOI.NE.(I0+NOUVI)) AA(ICHOI,JK)=0.D0
  188.        ENDDO
  189.  
  190.   265     CONTINUE
  191.   266     CONTINUE
  192.        DO LIK = I0+NMXCH+1,IN5
  193.          IDY(LIK)=0
  194.          DO JIK=1,NNN
  195.            AA(LIK,JIK)=0.D0
  196.          ENDDO
  197.        ENDDO
  198.        ENDIF
  199.   270  CONTINUE
  200.  
  201.          NN(L)=I-I0
  202. *        WRITE(6,*)' NN(',L,')',NN(L)
  203. *        write(6,*)'NN(4)',NN(4)
  204. 400   CONTINUE
  205.  
  206. C MISE EN IDP DES MINERAUX LORSQUE LMXMX=0
  207.        IF(LXMX.NE.0) THEN
  208.        SEGDES MLXMX
  209.        ELSE
  210.        NN123=NN(1)+NN(2)+NN(3)+1
  211.        NN45=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)
  212.        DO 600 N=NN123,NN45
  213.          NPDIM=NPDIM+1
  214.          SEGADJ IDSCHI
  215.          IDP(NPDIM)=IDY(N)
  216.   600  CONTINUE
  217.        ENDIF
  218. C
  219.       IF (I.LT.NYDIM) THEN
  220.         NYDIM=I
  221. *       write(6,*)'Fin chinp'
  222. *       WRITE(6,*)' NXDIM ',NXDIM,' NYDIM ',NYDIM,' NPDIM ',NPDIM,
  223. *     * ' NZDIM ',NZDIM
  224.         SEGADJ IDSCHI
  225.       ENDIF
  226.  
  227.       SEGSUP IZCOMP
  228.  
  229.   510 FORMAT (I5,F9.2,4(I4,I3),T43,A5)
  230. C 520 FORMAT((7X,A10,3(8X,A10)))
  231.   520 FORMAT((7X,A8,2X,3(8X,A8,2X)))
  232.   530 FORMAT (40I2)
  233.  
  234. C*****************REMISE EN TETE DES FICHIERS IOCHI1 ET IOCHI2******
  235.   500 CONTINUE
  236. C     REWIND(UNIT=IOCHI2)
  237. C     CLOSE(UNIT=IOCHI2)
  238. C     REWIND(UNIT=IOCHI1)
  239. C     CLOSE(UNIT=IOCHI1)
  240. C*******************************************************************
  241.  
  242.       RETURN
  243.       END
  244.  
  245.  
  246.  

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