Télécharger la plaquette Cast3M


fr en

Télécharger chinps.eso

Retour à la liste

Numérotation des lignes : 

chinps

  1. C CHINPS    SOURCE    OF166741  23/10/16    21:15:05     11754          
  2.  
  3.       SUBROUTINE CHINPS(IDSCHI,LXMX,IOCHI1,IOCHI2)
  4.  
  5. C=======================================================================
  6. C
  7. C !!!ATTENTION! POUR LE CHOIX DES MINERAUX A CONSIDERER CF CHINP
  8. C ------------------------------------------------------------------
  9. C ATTENTION|
  10. C   SP DE LECTURE CORRESPONDANT A LA BASE DE DONNEES DE STRASBOURG
  11. C   SOUS FORMAT MINEQL
  12. C  et aux bases issues de CHESS utilisables par CASTEM
  13. C
  14. C======================================================================
  15.       IMPLICIT INTEGER(I-N)
  16.       IMPLICIT REAL*8(A-H,O-Z)
  17.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20.  
  21. -INC SMLENTI
  22.       POINTEUR MLXMX.MLENTI
  23.  
  24.       SEGMENT IDSCHI
  25.            REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
  26.            INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
  27.            INTEGER IDECY(NYDIM),IONZ(NXDIM)
  28.            CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
  29.       ENDSEGMENT
  30.  
  31.       SEGMENT ITRAV
  32.          REAL*8 CIAT(NXCMP)
  33.          INTEGER IDT(NXCMP)
  34.       ENDSEGMENT
  35.  
  36.       SEGMENT IZCOMP
  37.         CHARACTER*32 NAM(NXD)
  38.         INTEGER ION(NXD),IADXT(NXD)
  39.       ENDSEGMENT
  40.  
  41.       CHARACTER*5 MOCLE
  42.       CHARACTER*32 NAMLXM
  43.       LOGICAL LIBRE
  44.  
  45.       NXDIM=IDX(/1)
  46.       NYDIM=IDY(/1)
  47.       NZDIM=IDZ(/1)
  48.       NPDIM=IDP(/1)
  49.       NNN=NXDIM
  50.       NOUVI=0
  51.  
  52.       LIBRE=.TRUE.
  53.       READ(IOCHI1,590)NXD,NAMLXM
  54.       IF(NAMLXM(1:10).NE.'COMPOSANTS')THEN
  55.            NXD=200
  56.            BACKSPACE IOCHI1
  57.            LIBRE=.FALSE.
  58.       ENDIF
  59.  
  60.       SEGINI IZCOMP
  61. C INITIALIZE ADDRESS
  62.       DO J=1,NXD
  63.         NAM(J)  ='                                '
  64.         ION(J)  =0
  65.         IADXT(J)=0
  66.       ENDDO
  67.  
  68. CBRUNO
  69.       IF(LIBRE)THEN
  70.             READ(IOCHI1,580) (NAM(J),J=1,NXD)
  71.       ELSE
  72.             READ(IOCHI1,520) (NAM(J)(1:12),J=1,NXD)
  73.       ENDIF
  74.       READ(IOCHI1,530) (ION(J),J=1,NXD)
  75.  
  76. C INITIALIZE NN
  77.       N3=0
  78.       NN(1)=0
  79.       NN(2)=0
  80.       NN(3)=0
  81.       NN(4)=0
  82.       NN(5)=0
  83.       NN(6)=0
  84.  
  85. C INITIALIZE A
  86.       DO J=1,NXDIM
  87.         DO I=1,NYDIM
  88.           AA(I,J)=0.D0
  89.         ENDDO
  90.       ENDDO
  91.  
  92. C INPUT BASIS IN A MATRIX
  93.       DO I=1,NNN
  94.         IDXT=IDX(I)
  95.         IF(IDXT.GT.NXD)THEN
  96.               INTERR(1)=IDXT
  97.               CALL ERREUR(781)
  98.               GO TO 500
  99.         ENDIF
  100. CBRUNO
  101.         NAME(I)=NAM(IDXT)
  102.         NAMESP(I)=NAM(IDXT)
  103.         IONZ(I)=ION(IDXT)
  104.          IADXT(IDXT)=I
  105.          IDY(I)=IDX(I)
  106.          AA(I,I)=1.D0
  107.          GK(I)=0.D0
  108.       ENDDO
  109.  
  110.       NN(1)=NNN
  111.  
  112. C ***************** LECTURE DES DONNEES THERMODYNAMIQUES
  113.       NXCMP=8
  114.       SEGINI ITRAV
  115.       I=NN(1)
  116.       DO 400 L=2,6
  117.          I0=I
  118.          READ(IOCHI2,540) IN,MOCLE,NBCMP
  119.          IF(MOCLE.EQ.'LIBRE')THEN
  120.              LIBRE=.TRUE.
  121.              NXCMP=NBCMP
  122.              SEGADJ ITRAV
  123.          ELSE
  124.              LIBRE=.FALSE.
  125.              NBCMP=8
  126.          ENDIF
  127.          IF(IN.EQ.0) GO TO 400
  128.          DO 300 II=1,IN
  129.            IF(LIBRE)THEN
  130.               READ(IOCHI2,550) IDYT,GKT,(IDT(J),CIAT(J),J=1,4)
  131.               J1=5
  132.               IF(NBCMP.GT.8)THEN
  133.                   NBENR=(NBCMP-8)/4
  134.                   DO 40 JJ=1,NBENR
  135.                      J2=J1+3
  136.                      READ(IOCHI2,560) (IDT(J),CIAT(J),J=J1,J2)
  137.                      J1=J1+4
  138.    40             CONTINUE
  139.               ENDIF
  140.               READ(IOCHI2,560) (IDT(J),CIAT(J),J=J1,NBCMP),
  141.      *        LLXM,NAMLXM
  142. C             WRITE(ioimp,*) IDYT,GKT,(IDT(J),CIAT(J),J=1,NBCMP),
  143. C    *        LLXM,NAMLXM
  144.            ELSE
  145.                READ(IOCHI2,510) IDYT,GKT,(IDT(J),CIAT(J),J=1,8),
  146.      *          LLXM,NAMLXM
  147.            ENDIF
  148.  
  149.            DO 310 J=1,8
  150.               JTEST=IDT(J)
  151.               IF(JTEST.EQ.0) GO TO 310
  152.               IF(IADXT(JTEST).EQ.0) GO TO 300
  153. 310        CONTINUE
  154.  
  155.             I=I+1
  156.             IF (I.GT.NYDIM)THEN
  157.                   MOTERR(1:8)=' CHMMX '
  158.                   MOTERR(9:16)='SUITENTI'
  159.                   CALL ERREUR(787)
  160.                   RETURN
  161.             ENDIF
  162.             IDY(I)=IDYT
  163.             GK(I)=GKT
  164.             NAMESP(I)=NAMLXM
  165.             DO J=1,8
  166.                JTEST=IDT(J)
  167.                IF (JTEST.NE.0) THEN
  168.                  IF (JTEST.EQ.90) N3=N3+1
  169.                  IADTJT=IADXT(JTEST)
  170.                  AA(I,IADTJT)=CIAT(J)
  171.                ENDIF
  172.             ENDDO
  173. 300      CONTINUE
  174.  
  175. *-----------------***------MONI------***-------------------------------
  176. *   CES MODIFS PERMETTENT DE FAIRE UN CHOIX DES MINERAUX A PRENDRE
  177. *   EN COMPTE; AVEC MINEQL IL EXISTE UNE FACON BIEN PLUS SIMPLE ET
  178. *   AUSSI EFFICACE :
  179. *             METTRE, DANS LE MAIN, TOUTES LES ESPECES DE TYPE 5
  180. *   (MINERAL DISSOUS QUI PEUT PRECIPITER S'IL ARRIVE A SATURATION),
  181. *   EN TYPE 6 :
  182. *              NN(6)=NN(5)+NN(6)
  183. *              NN(5)=0
  184. *     PUIS, SELECTIONNER EN TYPE 5 LES MINERAUX CHOISIS :
  185. *      EX:
  186. *              I5=5
  187. *              I6=6
  188. *              CALL EXTYP(02231,I6,I5)
  189. **********************************************************************
  190.       NBT5=0
  191.       IF (L.EQ.5) THEN
  192.        IF(LXMX.EQ.0) GOTO 270
  193.        MLXMX=LXMX
  194.        SEGACT MLXMX
  195.        NMXCH=MLXMX.LECT(/1)
  196.  
  197. CPATBOS---------------------------------------------
  198. C    MISE EN IDP DES MINERAUX CHOISIS PAR L UTILISATEUR
  199.        NPDIM=NMXCH
  200.        SEGADJ IDSCHI
  201.        CALL RSETI(IDP,MLXMX.LECT,NPDIM)
  202.        IN5=I
  203. C -------
  204. *C     RECHERCHE DES MINERAUX NON PRIS EN COMPTE
  205. C ----
  206.           III=I
  207.           DO 266 ICHOI=I0+1,III
  208.            DO 267 NM0=1,NMXCH
  209.              IF (IDY(ICHOI).EQ.MLXMX.LECT(NM0)) THEN
  210.                  NOUVI=NOUVI+1
  211.                  IDY(I0+NOUVI)=IDY(ICHOI)
  212.                  GK(I0+NOUVI)=GK(ICHOI)
  213.                  NAMESP(I0+NOUVI)=NAMESP(ICHOI)
  214.                   DO JK=1,NNN
  215.                     AA(I0+NOUVI,JK)=AA(ICHOI,JK)
  216.                   ENDDO
  217.                   GOTO 265
  218.              ENDIF
  219.   267      CONTINUE
  220.  
  221.            IDY(ICHOI)=0
  222.            GK(ICHOI)=0.D0
  223.            NAMESP(ICHOI)='                                '
  224.             DO JK=1,NNN
  225.               AA(ICHOI,JK)=0.D0
  226.             ENDDO
  227.  
  228.             I=I-1
  229.   265     CONTINUE
  230.   266     CONTINUE
  231.  
  232.          DO LIK = I0+NMXCH+1,IN5
  233.            IDY(LIK)=0
  234.            DO JIK=1,NNN
  235.              AA(LIK,JIK)=0.D0
  236.            ENDDO
  237.          ENDDO
  238.        ENDIF
  239.  
  240.   270  CONTINUE
  241.  
  242.          NN(L)=I-I0
  243. 400   CONTINUE
  244.  
  245. C MISE EN IDP DES MINERAUX LORSQUE LMXMX=0
  246.        IF(LXMX.NE.0)THEN
  247.        SEGDES MLXMX
  248.        ELSE
  249.        NN123=NN(1)+NN(2)+NN(3)+1
  250.        NN45=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)
  251.        DO N=NN123,NN45
  252.          NPDIM=NPDIM+1
  253.          SEGADJ IDSCHI
  254.          IDP(NPDIM)=IDY(N)
  255.        ENDDO
  256.        ENDIF
  257.  
  258. CMONI*************LE 1 MARS 91****************************************
  259.       IF (I.LT.NYDIM) THEN
  260.         NYDIM=I
  261.         SEGADJ IDSCHI
  262.       ENDIF
  263.       SEGSUP IZCOMP
  264.       SEGSUP ITRAV
  265. CMONI*****************************************************************
  266.   510 FORMAT (I5,F9.3,4(I4,1F6.2),/,14X,4(I4,1F6.2),T57,I1,1X,A32)
  267. C  520 FORMAT((7X,A10,3(8X,A10)))
  268. C  520 FORMAT (4(8X,A8,2X))
  269.   520 FORMAT(2X,4(6X,A12))
  270.   530 FORMAT (40I2)
  271.   540 FORMAT (I5,2X,A5,I5)
  272.   550 FORMAT (I5,F10.8,4(I5,1X,1F6.4))
  273.   560 FORMAT (15X,4(I5,1X,1F6.4),T66,I1,1X,A22)
  274.   570 FORMAT (I5,3X,A12)
  275.   580 FORMAT (8X,A32)
  276.   590 FORMAT (I8,A32)
  277.  
  278. C*****************REMISE EN TETE DES FICHIERS ****************
  279.   500 CONTINUE
  280. C     REWIND(UNIT=IOCHI2)
  281. C     CLOSE(UNIT=IOCHI2)
  282. C     REWIND(UNIT=IOCHI1)
  283. C     CLOSE(UNIT=IOCHI1)
  284. C*******************************************************************
  285. C     WRITE(IOIMP,*) 'A LA SORTIE DE CHINPS , J= ',J
  286.  
  287.       RETURN
  288.       END
  289.  
  290.  
  291.  

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