Télécharger chiesp.eso

Retour à la liste

chiesp
C CHIESP    SOURCE    CHAT      05/01/12    21:57:16     5004
      SUBROUTINE CHIESP(NVESP,IDSCHI)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C------------------------------------------------------------------
C
C     PRISE EN COMPTE DE NOUVELLES ESPECES
C
C------------------------------------------------------------------
-INC SMTABLE
-INC SMLENTI
-INC SMLREEL
 
-INC PPARAM
-INC CCOPTIO
      POINTEUR MLIDEN.MLENTI
      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=NVESP
      SEGACT MTAB1
      NNESP= MTAB1.MLOTAB
C     WRITE(6,*)'CHIESP',NNESP
      NBIESP=NNESP
         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   on a trouvé CLASSE c'est un objet on va compter les indices entier
         NBIESP= 0
      DO 5 IESP=1,NNESP
C     write(6,*)' chiesp',mtabti(iesp),mtabtv(iesp),RMTABI(iesp),
C    * MTABII(iesp),MTABIV(iesp),RMTABV(iesp)
      IF((MTAB1.MTABTI(IESP)).EQ.'ENTIER') NBIESP= NBIESP+1
    5 CONTINUE
       ENDIF
      DO 80 IESP=1,NBIESP
         IVALI=IESP
         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
         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
         IDESP=IVALR
         IVALI=1
         XVALI=0.D0
         IRETI=0
         IVALR=0
         XVALR=0.D0
         IRETR=0
         MTYPI='MOT     '
         MTYPR='FLOTTANT'
         CHARR='        '
         CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'LOGK',.TRUE.,IRETI,
     *        MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
         IF(IERR.NE.0)RETURN
         SEGACT MTAB1
         GKESP=XVALR
         IVALI=1
         XVALI=0.D0
         IRETI=0
         IVALR=0
         XVALR=0.D0
         IRETR=0
         MTYPI='MOT     '
         MTYPR='        '
         CHARR='        '
         CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'COMP',.TRUE.,
     *        IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
         SEGACT MTAB1
         IF(MTYPR.EQ.'        ')THEN
            CALL CHIADY(IDY,NYDIM,IDESP,K)
            IF(K.EQ.0) THEN
C     WRITE(6,*)' MODIF LOGK DE L ESPECE ',IDESP,' IMPOSSIBLE'
C     WRITE(6,*)' CETTE ESPECE N A PAS ÉTÉ RETENUE  '
               MOTERR(1:40)='********** NVESP . LOGK                 '
               CALL ERREUR(-301)
               INTERR(1)=IDESP
               CALL ERREUR(776)
               RETURN
            ENDIF
            GK(K)=GKESP
         ELSEIF(MTYPR.EQ.'LISTENTI')THEN
            MLENTI=IRETR
            SEGACT MLENTI
            CALL CHIADY(IDY,NYDIM,IDESP,K)
            IF(K.NE.0) THEN
C     WRITE(6,*)' L ESPECE ',IDESP,' EXISTE DEJA '
               INTERR(1)=IDESP
               CALL ERREUR(777)
               RETURN
            ENDIF
            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,'ITYP',.TRUE.,IRETI,
     *           MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
            IF(IERR.NE.0)RETURN
         SEGACT MTAB1
            ITJP=IVALR
            IVALI=1
            XVALI=0.D0
            IRETI=0
            IVALR=0
            XVALR=0.D0
            IRETR=0
            MTYPI='MOT     '
            MTYPR='LISTREEL'
            CHARR='        '
            CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'STOECH',.TRUE.,
     *           IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
            IF(IERR.NE.0)RETURN
         SEGACT MTAB1
            MLREEL=IRETR
            SEGACT MLREEL
         IVALI=1
         XVALI=0.D0
         IRETI=0
         IVALR=0
         XVALR=0.D0
         IRETR=0
         MTYPI='MOT     '
         MTYPR='        '
         CHARM='                                '
         CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'NOMESPECE',.TRUE.,IRETI,
     *        MTYPR,IVALR,XVALR,CHARM,LOGRE,IRETR)
         IF(IERR.NE.0)RETURN
         SEGACT MTAB1
C
C     ON TRAITE
C
C     WRITE(6,*)'CHIESP ',IDESP,ITJP,GKESP,MLENTI,MLREEL
            LB=LECT(/1)
            LC=PROG(/1)
            IF(LB.NE.LC)THEN
               MOTERR(1:40)='********** NVESP . STOECH               '
               CALL ERREUR(-301)
               CALL ERREUR(21)
               RETURN
            ENDIF
***   VERIF COMPOSITION
            DO 20 L=1,LB
               IF(LECT(L).NE.0) THEN
                  IDCK = LECT(L)
                  CALL CHIADY(IDX,NXDIM,IDCK,K)
                  IF(K.EQ.0) THEN
C     WRITE(6,*)' LE COMPOSANT ',IDCK,' N A PAS ÉTÉ RETENU'
C     WRITE(6,*)' LE COMPLEXE ',IDESP,' NE PEUT ETRE FORMÉ '
                     MOTERR(1:40)='************ NVESP . COMP         '
                     CALL ERREUR(-301)
                     INTERR(1)=IDCK
                     CALL ERREUR(776)
                     RETURN
                  ENDIF
               ELSE
                  GOTO 30
               ENDIF
 20         CONTINUE
***   INSERTION
 30         CONTINUE
            NN(6)=NN(6)+1
            NYDIM=NYDIM+1
            SEGADJ IDSCHI
            IDY(NYDIM)=IDESP
            DO 40 IX=1,LB
               IF(LECT(IX).EQ.0) GO TO 50
               IDCK = LECT(IX)
               CALL CHIADY(IDX,NXDIM,IDCK,IK)
               AA(NYDIM,IK)=PROG(IX)
               GK(NYDIM)  =GKESP
               NAMESP(NYDIM)=CHARM
 40         CONTINUE
 50         CONTINUE
*     WRITE(6,*)' IDJP ',IDJP,' ITJP ',ITJP
            LINIT=6
            CALL CHIREX(IDSCHI,IDESP,LINIT,ITJP )
            IF(ITJP.NE.2)THEN
               NPDIM=NPDIM+1
               SEGADJ IDSCHI
               IDP(NPDIM)=IDESP
            ENDIF
            SEGDES MLENTI,MLREEL
         ELSE
            MOTERR(1:11)='COMP       '
            MOTERR(12:20)='LISTENTI'
            CALL ERREUR(627)
            RETURN
         ENDIF
         SEGDES MTAB2
      ELSE
        MOTERR(1:40)='********         NVESP     ???????????  '
        CALL ERREUR(-301)
      CALL ERREUR(21)
      RETURN
      ENDIF
 80   CONTINUE
      SEGDES MTAB1
*     WRITE(6,*)'IDX',(IDX(I),I=1,NXDIM)
*     WRITE(6,*)'IDY',(IDY(I),I=1,NYDIM)
*     write(6,*)'chiesp IDP',(idp(i),i=1,npdim)
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
 
 
 
 
 
 
 
 
 

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