Sources Esope | Cast3M

chicmp
C CHICMP    SOURCE    CHAT      05/01/12    21:57:00     5004
      SUBROUTINE CHICMP(NVCOMP,IDSCHI)
      IMPLICIT INTEGER(I-N)
        IMPLICIT REAL*8 (A-H,O-Z)
C -------------------------------------------------------------------
C
C              AJOUT DE NOUVELLES COMPOSANTES ( CHIMIE)
C
C -------------------------------------------------------------------
-INC SMTABLE
-INC SMLENTI
      POINTEUR MLIDEN.MLENTI,MLXMX.MLENTI
 
-INC PPARAM
-INC CCOPTIO
      SEGMENT IDSCHI
           REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
           INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
           INTEGER IDECY(NYDIM),IONZ(NXDIM)
           CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
      ENDSEGMENT
      CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR
      CHARACTER*32 CHARM
      LOGICAL LOGRE
      INTEGER LINIT
C
      NYDIM=IDY(/1)
      NXDIM=IDX(/1)
      NZDIM=IDZ(/1)
      NPDIM=IDP(/1)
      MTAB1=NVCOMP
      SEGACT MTAB1
      NNCOMP= MTAB1.MLOTAB
      NICOMP=NNCOMP
      IVALI=0
      XVALI=0.D0
      IRETI=0
      IVALR=0
      XVALR=0.D0
      IRETR=0
      MTYPI='MOT     '
      MTYPR='        '
      CHARR='        '
      CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'CLASSE',.TRUE.,IRETI,
     *        MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
      IF(IERR.NE.0)RETURN
      SEGACT MTAB1
      IF(MTYPR.EQ.'MOT     ')THEN
C
C   on a trouvé CLASSE c'est un OBJET on va compter les indices entier
C
      NICOMP= 0
      DO 5 IESP=1,NNCOMP
      IF((MTAB1.MTABTI(IESP)).EQ.'ENTIER') NICOMP= NICOMP+1
    5 CONTINUE
       ENDIF
      DO 50 ICOMP=1,NICOMP
      IVALI=ICOMP
      XVALI=0.D0
      IRETI=0
      IVALR=0
      XVALR=0.D0
      IRETR=0
      MTYPI='ENTIER  '
      MTYPR='        '
      CHARR='        '
      CHARI='        '
      CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,CHARI,.TRUE.,IRETI,
     *MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
      IF(IERR.NE.0)RETURN
      SEGACT MTAB1
      IF((MTYPR.EQ.'TABLE   ').OR.(MTYPR.EQ.'OBJET   ')) THEN
      MTAB2=IRETR
      SEGACT MTAB2
      NXDIM=NXDIM+1
      NYDIM=NYDIM+1
      SEGADJ IDSCHI
      IVALI=1
      XVALI=0.D0
      IRETI=0
      IVALR=0
      XVALR=0.D0
      IRETR=0
      MTYPI='MOT     '
      MTYPR='ENTIER  '
      CHARR='        '
      CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'IDEN',.TRUE.,IRETI,
     *MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
      IF(IERR.NE.0)RETURN
      SEGACT MTAB1
      NVIDEN=IVALR
      IVALI=1
      XVALI=0.D0
      IRETI=0
      IVALR=0
      XVALR=0.D0
      IRETR=0
      MTYPI='MOT     '
      MTYPR='MOT     '
      CHARM='                                '
      CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'NOM',.TRUE.,IRETI,
     * MTYPR,IVALR,XVALR,CHARM,LOGRE,IRETR)
      SEGACT MTAB1
      IF(IERR.NE.0)RETURN
      NAME(NXDIM)=CHARM
      IVALI=1
      XVALI=0.D0
      IRETI=0
      IVALR=0
      XVALR=0.D0
      IRETR=0
      MTYPI='MOT     '
      MTYPR='ENTIER  '
      CHARR='        '
      CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'CHARGE',.TRUE.,
     *IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
      IF(IERR.NE.0)RETURN
      SEGACT MTAB1
      IONZ(NXDIM)=IVALR
      NN(6)=NN(6)+1
      IDY(NYDIM)=NVIDEN
      LINIT=6
      CALL CHIREX(IDSCHI,NVIDEN,LINIT,1)
      AA(NN(1),NXDIM)=1.D0
      IDX(NXDIM)=NVIDEN
      GK(NN(1))=0.D0
      SEGDES MTAB2
      ELSE
        MOTERR(1:40)='********         NVCOMP    ???????????  '
        CALL ERREUR(-301)
      CALL ERREUR(21)
      RETURN
      ENDIF
   50 CONTINUE
      SEGDES MTAB1
C     WRITE(6,*)' FIN CHICMP NXDIM NYDIM' ,NXDIM,NYDIM
C      WRITE(6,*)(NAME(I),I=1,NXDIM)
C      WRITE(6,*)'IDX',(IDX(I),I=1,NXDIM)
C      WRITE(6,*)'IDY',(IDY(I),I=1,NYDIM)
C      WRITE(6,*)'GK',(GK(I),I=1,NYDIM)
C      WRITE(6,110)((AA(I,J),I=1,NYDIM),J=1,NXDIM)
  110 FORMAT( 2X ,'AA',(10(1PE10.3)))
 
 
 
      RETURN
      END