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