C CHIRED SOURCE CHAT 05/01/12 21:57:59 5004 SUBROUTINE CHIRED(IDSCHI,MTAB1,MTAB2,IZIADR,IADH,MLENT3,LIMP3) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C------------------------------------------------------------------ C C CHARGEMENT DES TABLES IDEN ET REDOX C MTAB1 = POINTEUR TABLE IDEN C MTAB2 = POINTEUR TABLE REDOX C = 0 EN ENTREE C MLENT3= POINTEUR DES COMPOSANTS IMMOBILES POUR C LES CONDITIONS AUX LIMITES DES TYPE 3 C ( LU ET VERIFIE DANS CHICLM ,PEUT ETRE NUL) C LIMP3 = POINTEUR DE LA LISTE DES ESPECES MISES EN C TYP3 PAR CLIM ( TAB1.CLIM.TYP3) C C------------------------------------------------------------------ -INC SMTABLE -INC SMLENTI -INC SMLREEL -INC SMLMOTS -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 SEGMENT IZIADR INTEGER IADR(NCR) ENDSEGMENT SEGMENT IZRED INTEGER ITAB(NCR,2) REAL*8 ATAB(NCR,2) ENDSEGMENT SEGMENT IZREDI INTEGER IRCR(MCR),ICR(LCR) ENDSEGMENT SEGMENT IZIMM INTEGER IADE(NCE),IADC(NCC),IMM(NIMM) ENDSEGMENT SEGMENT IZRIAD INTEGER IRAD(NIRA),ICONS(NXDIM) ENDSEGMENT SEGMENT IZSS INTEGER ISOLU(NYDIM),ISURF(NYDIM) ENDSEGMENT CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR C C CHITRI1 CREE ET CHARGE IZIADR et IADH IZRED=0 IZREDI=0 IF(IZIADR.NE.0)THEN C CHITRI CREE ET CHARGE IZRED CALL CHITRI(IDSCHI,IZIADR,IZRED,IZREDI) ENDIF NXDIM=IDX(/1) NYDIM=IDY(/1) NZDIM=IDZ(/1) NPDIM=IDP(/1) JSOH=0 NCE=NN(3) NCC=NN(3) NIRA=NXDIM NIMM=NXDIM SEGINI IZIMM ,IZRIAD C ON VA METTRE DANS IRAD UN INDICE POUR CHAQUE C COMPOSANT 3=IMMOBILE 2=REACTIFS 1=CONSERVATIF CALL INITI(IRAD,NIRA,2) C TRI RELATION TYP3 NCE=0 NCC=0 JI=NN(1)+NN(2)+1 JM= NN(1)+NN(2)+NN(3) DO 20 JJ=JI,JM DO 10 J=1,NXDIM IF (IDX(J).EQ.IDY(JJ)) THEN NCE =NCE+1 IADE(NCE)=IDX(J) IRAD(J)=3 GO TO 16 ENDIF 10 CONTINUE NCC =NCC+1 IADC(NCC)=IDY(JJ) 16 CONTINUE 20 CONTINUE C------------------------------------------------------------- C RECHERCHE DES COMPOSANTS NON TRANSPORTES NIMM=0 IF(IADH.NE.0)THEN NIMM=NIMM+1 IMM(NIMM)=60 CALL CHIADY(IDX,NXDIM,60,III) IRAD(III)=3 ENDIF IF(IZRED.NE.0)THEN MCR=IRCR(/1) CALL RSETI(IMM(NIMM+1),IRCR,MCR) NIMM=NIMM+MCR DO 25 J=1,MCR JJ=IRCR(J) CALL CHIADY(IDX,NXDIM,JJ,III) IRAD(III)=3 25 CONTINUE ENDIF IF(NCE.NE.0)THEN CALL RSETI(IMM(NIMM+1),IADE,NCE) NIMM=NIMM+NCE ENDIF JN=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)+1 JK=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)+NN(6) NADSORB=0 DO 40 J=1,NXDIM IF(IDX(J).EQ.80) NADSORB=NADSORB+1 C /TEST SUR LES SITES DE SURFACES/ IF (IDX(J).GE.90.AND.IDX(J).LE.96) THEN C NADSORB=NADSORB+1 NIMM=NIMM+1 IMM(NIMM)=IDX(J) IRAD(J)=3 ENDIF C /TEST SUR LES COMPOSANTS DE TYPE 6/ DO 30 JJ=JN,JK IF (IDX(J).EQ.IDY(JJ)) THEN IF ( IDX(J).NE.99) THEN NIMM=NIMM+1 IMM(NIMM)=IDX(J) IRAD(J)=3 ENDIF ENDIF 30 CONTINUE 40 CONTINUE C PRISE EN COMPTE DES COMPOSANTS IMMOBILES DE CLIM TYP3 C ON A DEJA VERIFIE LEUR EXISTANCE IF(MLENT3.GT.0)THEN NL=MLENT3.LECT(/1) MLENT1=LIMP3 SEGACT MLENT1 DO 35 J=1,NL IDXT=MLENT3.LECT(J) IDYT= MLENT1.LECT(J) IF(IDXT.NE.IDYT)THEN C ON VERIFIE QUE IDXT N'EST PAS DEJA IMMOBILE CALL CHIADY(IMM,NIMM,IDXT,III) IF(III.EQ.0)THEN NIMM=NIMM+1 IMM(NIMM)=IDXT CALL CHIADY(IDX,NXDIM,IDXT,JJ) IRAD(JJ)=3 ELSE C WRITE(6,*) ' LE COMPOSANT ',IDXT,' EST DEJA IMMOBILE' INTERR(1)=IDXT CALL ERREUR(778) RETURN ENDIF ENDIF 35 CONTINUE SEGDES MLENT1 ENDIF C ---------------------------------------------------- C C RECHERCHE DU NOMBRE DE COMPOSANTS CONSERVATIFS: NCONS NCONS=0 C TEST DE LA PRESENCE D'UN COMPOSANT DANS UNE ESPECE ADSORBEE IJ=NN(1)+1 IK=NN(1)+NN(2)+NN(3)+NN(4) CALL CHIADY(IDX,NXDIM,90,JSOH) DO 65 J=1,NXDIM IF(JSOH.GT.0) THEN DO 45 I=IJ,IK IF (AA(I,JSOH).GT.0.D0.AND.ABS(AA(I,J)).GT.0.D0) GOTO 60 45 CONTINUE ENDIF C/ TEST DE LA PRESENCE D'UN COMPOSANT DANS UNE ESPECE SOLIDE C DE TYPE 3, 4 OU 5. JI=NN(1)+NN(2)+1 IM=NN(1)+NN(2)+NN(3)+NN(4)+NN(5) DO 50 I=JI,IM IF (ABS(AA(I,J)).GT.0.D0) THEN * WRITE(6,*) ' SOLIDE ',IDX(J) GO TO 60 ENDIF 50 CONTINUE ** ESPECE ECHANGEE DO 55 I = IJ,IK IF (ABS(AA(I,J)).GT.0.D0) THEN IF(IDECY(I).NE.0) THEN C WRITE(6,*) ' ECHANGE',IDX(J) GO TO 60 ENDIF ENDIF 55 CONTINUE IF(IRAD(J).NE.3)THEN NCONS=NCONS+1 ICONS(NCONS)=IDX(J) IRAD(J)=1 C WRITE(6,*) 'ICONS(',N,'): ',IDX(J) ENDIF 60 CONTINUE 65 CONTINUE C -------------------------------------------------------- SEGACT MTAB1 IVALI=0 XVALI=0.D0 IRETI=0 IVALR=0 XVALR=0.D0 MTYPI='MOT ' IF(NIMM.NE.0)THEN JG=NIMM SEGINI MLENTI CALL RSETI(LECT,IMM,JG) IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'IMMO',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI ENDIF IF(NCONS.NE.0)THEN JG=NCONS SEGINI MLENTI CALL RSETI(LECT,ICONS,JG) IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'PARF',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI ENDIF C COMPOSANTS REACTIFS JJG=NXDIM-NCONS-NIMM IF(JJG.NE.0)THEN JG=JJG SEGINI MLENTI I=0 DO 70 J=1,NXDIM IF(IRAD(J).EQ.2)THEN I=I+1 LECT(I)=IDX(J) ENDIF 70 CONTINUE IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'REAC',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI ENDIF IF(NN(6).NE.0)THEN C TYP6 JG=NN(6) SEGINI MLENTI JN=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)+1 CALL RSETI(LECT,IDY(JN),JG) IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'TYP6',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI JGN=4 JGM=JG SEGINI MLMOTS DO 71 I=1,JG NLL=JN-1+I WRITE(MOTS(I),110)NLL 71 CONTINUE IRETR=MLMOTS MTYPR='LISTMOTS' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMTYP6',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLMOTS ENDIF C TYP3 IF(NN(3).NE.0)THEN JG=NN(3) SEGINI MLENTI JN=NN(1)+NN(2)+1 CALL RSETI(LECT,IDY(JN),JG) IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'TYP3',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI JGN=4 JGM=JG SEGINI MLMOTS DO 72 I=1,JG NLL=JN-1+I WRITE(MOTS(I),110)NLL 72 CONTINUE IRETR=MLMOTS MTYPR='LISTMOTS' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMTYP3',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLMOTS IF(LIMP3.NE.0) THEN IRETR=LIMP3 MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'IMP3',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) ENDIF ENDIF C PRECIPITES POTENTIELS JJG=NN(4)+NN(5) IF(JJG.NE.0)THEN JG=JJG SEGINI MLENTI JN=NN(1)+NN(2)+NN(3)+1 CALL RSETI(LECT,IDY(JN),JG) IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'PRECI',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI JGN=4 JGM=JG SEGINI MLMOTS DO 75 I=1,JG NLL=JN-1+I WRITE(MOTS(I),110)NLL 75 CONTINUE IRETR=MLMOTS MTYPR='LISTMOTS' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMPRECI',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLMOTS ENDIF C SOLUTIONS SOLIDES IF(NZDIM.NE.0)THEN JG=NN(4)+NN(5)+NN(6) SEGINI MLENTI KS=0 JN=NN(1)+NN(2)+NN(3)+1 DO L=1,JG NII=JN-1+L IDYNI=IDY(NII) CALL CHIADY(IDZ,NZDIM,IDYNI,IDNI) IF(IDNI.NE.0)THEN KS=KS+1 LECT(KS)=IDYNI ENDIF END DO JG=KS SEGADJ MLENTI IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'SOSO',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI JGN=4 JGM=NN(4)+NN(5)+NN(6) SEGINI MLMOTS KM=0 DO I=1,JGM NLL=JN-1+I IDYNL=IDY(NLL) CALL CHIADY(IDZ,NZDIM,IDYNL,IDNL) IF(IDNL.NE.0)THEN KM=KM+1 WRITE(MOTS(KM),110)NLL ENDIF END DO JGM=KM SEGADJ MLMOTS IRETR=MLMOTS MTYPR='LISTMOTS' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMSOSO',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLMOTS ENDIF C POLES DE SOLUTIONS SOLIDES IF(NZDIM.NE.0)THEN IF(NPDIM.NE.0)THEN JG=NN(6) SEGINI MLENTI KL=0 JN=NN(1)+NN(2)+NN(3)+NN(4)+NN(5)+1 DO L=1,NN(6) NII=JN-1+L IDYNI=IDY(NII) CALL CHIADY(IDP,NPDIM,IDYNI,IDNI) IF(IDNI.NE.0)THEN DO K=1,NZDIM IF(FF(K,IDNI).NE.0.D0)THEN KL=KL+1 LECT(KL)=IDYNI ENDIF END DO ENDIF END DO JG=KL SEGADJ MLENTI IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'POLE',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI JGN=4 JGM=NN(6) SEGINI MLMOTS KM=0 DO I=1,NN(6) NLL=JN-1+I IDYNL=IDY(NLL) CALL CHIADY(IDP,NPDIM,IDYNL,IDNL) IF(IDNL.NE.0)THEN DO K=1,NZDIM IF(FF(K,IDNL).NE.0.D0)THEN KM=KM+1 WRITE(MOTS(KM),110)NLL ENDIF END DO ENDIF END DO JGM=KM SEGADJ MLMOTS IRETR=MLMOTS MTYPR='LISTMOTS' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMPOLE',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLMOTS ENDIF ENDIF C TABLEAU IRAD JG=NXDIM SEGINI MLENTI CALL RSETI(LECT,IRAD,JG) IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'COMP',.TRUE., *IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI SEGSUP IZIMM ,IZRIAD C ESPECES SOLUBLES C ET ESPECES DE SURFACE C A COMPLETER POUR LES ESPECES DE SURFACE SEGINI IZSS N1=0 N3=0 JK=NN(1)+NN(2) DO 85 I=1,JK IF(IDECY(I).NE.0)THEN N3=N3+1 ISURF(N3)=IDY(I) GO TO 82 ENDIF N1=N1+1 ISOLU(N1)=IDY(I) 82 CONTINUE 85 CONTINUE IF ( N1.LT.1)THEN C WRITE(6,*)' IL N Y A PAS D ESPECE EN SOLUTION ' CALL ERREUR(779) RETURN ENDIF DO 88 I=1,NXDIM IF(IDX(I).EQ.99)THEN CALL CHIADY(IDY,NYDIM,99,J) IF( J.GT.NN(1)+NN(2)+NN(3))THEN N1=N1+1 ISOLU(N1)=99 ENDIF GO TO 90 ENDIF 88 CONTINUE 90 CONTINUE C ESPECES EN SOLUTION JG=N1 SEGINI MLENTI CALL RSETI(LECT,ISOLU,JG) IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'SOLU',.TRUE., *IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI JGN=4 JGM=JG SEGINI MLMOTS DO 92 I=1,JG CALL CHIADY(IDY,NYDIM,ISOLU(I),NLL) WRITE(MOTS(I),110)NLL 92 CONTINUE IRETR=MLMOTS MTYPR='LISTMOTS' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMSOLU',.TRUE., *IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLMOTS C ESPECES DE SURFACE IF(N3.NE.0)THEN JG=N3 SEGINI MLENTI CALL RSETI(LECT,ISURF,JG) IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'SURF',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI JGN=4 JGM=JG SEGINI MLMOTS DO 93 I=1,JG CALL CHIADY(IDY,NYDIM,ISURF(I),NLL) WRITE(MOTS(I),110)NLL 93 CONTINUE IRETR=MLMOTS MTYPR='LISTMOTS' CHARR=' ' CALL ECCTAB(MTAB1,MTYPI,IVALI,XVALI,'NOMSURF',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLMOTS ENDIF SEGSUP IZSS C DESCRIPTION DES REDOX IF(IZRED.NE.0)THEN CALL CRTABL(MTAB2) NCR=ITAB(/1) JG=NCR SEGINI MLENTI if (jg.ne.0) CALL RSETI(LECT,ITAB(1,1),JG) IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB2,MTYPI,IVALI,XVALI,'I1',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI SEGINI MLENTI if (jg.ne.0) CALL RSETI(LECT,ITAB(1,2),JG) IRETR=MLENTI MTYPR='LISTENTI' CHARR=' ' CALL ECCTAB(MTAB2,MTYPI,IVALI,XVALI,'I2',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLENTI SEGINI MLREEL if (jg.ne.0) CALL RSETD(PROG,ATAB(1,1),JG) IRETR=MLREEL MTYPR='LISTREEL' CHARR=' ' CALL ECCTAB(MTAB2,MTYPI,IVALI,XVALI,'A1',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLREEL SEGINI MLREEL if (jg.ne.0) CALL RSETD(PROG,ATAB(1,2),JG) IRETR=MLREEL MTYPR='LISTREEL' CHARR=' ' CALL ECCTAB(MTAB2,MTYPI,IVALI,XVALI,'A2',.TRUE., * IRETI,MTYPR,IVALR,XVALR,CHARR,.TRUE.,IRETR) SEGDES MLREEL SEGSUP IZIADR, IZRED,IZREDI ENDIF 110 FORMAT('W',I3.3) RETURN END