C NEUTRE SOURCE CB215821 20/11/25 13:34:47 10792 SUBROUTINE NEUTRE C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C OPERATEUR NEUT C C CALCULE LE BILAN ELECTRIQUE D'UNE SOLUTION CHIMIQUE C UTILISE LES RESULTATS DE CHI1 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMLENTI -INC SMLMOTS -INC SMCHPOI -INC SMELEME POINTEUR MLAA.MLREEL,MLOGK.MLREEL,MLFF.MLREEL POINTEUR MLIDX.MLENTI,MLIDY.MLENTI,MLIDZ.MLENTI,MLIDP.MLENTI POINTEUR MLNN.MLENTI,MLDECY.MLENTI POINTEUR MLIONZ.MLENTI,MLPREC.MLENTI POINTEUR MLNAME.MLMOTS,MLNESP.MLMOTS POINTEUR MLSOLU.MLENTI,MMSOLU.MLMOTS POINTEUR MCNEUT.MCHPOI,ICNEUT.MPOVAL CHARACTER*8 TYPEMA 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 SP2 REAL*8 GX(NXDIM),XX(NXDIM),GS(NZDIM),SS(NZDIM) REAL*8 TOT(NXDIM),TOTAQ(NXDIM),TOTFIX(NXDIM),GKS(NZDIM) REAL*8 YY(NXDIM),ZZ(NXDIM,NXDIM),CC(NYDIM),GC(NYDIM) ENDSEGMENT SEGMENT IZBID INTEGER IBID(NSOL) ENDSEGMENT C C C LECTURE DE LA TABLE CHIMI1 CALL CHMDEB(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,MLDECY, * MLNAME,MLIONZ,ITIDEN,ITREDO,ITEMPE,MLNESP) IF(IERR.NE.0)RETURN C C LECTURE DE LA TABLE IDEN C TOUS LES SEGMENTS REVIENNENT ACTIFS OU AVEC UN POINTEUR NUL C CALL CHMIDE(ITIDEN,MLCOMP,MLSOLU,MMSOLU,MLPREC,MMPREC,MLSURF, * MMSURF,MLTYP3,MMTYP3,MLTYP6,MMTYP6,MLPARF,MLREAC,MLIMMO, * MLPOLE,MMPOLE,MLSOSO,MMSOSO,LIMP3) IF(IERR.NE.0)RETURN C C LECTURE DU CHPOIN DES CONCENTRATIONS C CALL LIROBJ('CHPOINT',MCHPOI,0,IRETOU) IF(IRETOU.EQ.0)THEN CALL ERREUR(21) RETURN ENDIF SEGACT MCHPOI NSOUPO=IPCHP(/1) IF(NSOUPO.NE.1)THEN CALL ERREUR(21) RETURN ENDIF MSOUPO=IPCHP(1) SEGACT MSOUPO MELEME=IGEOC MPOVAL=IPOVAL NC=NOCOMP(/2) NSOL=MLSOLU.LECT(/1) SEGINI IZBID DO 20 I=1,NSOL DO 25 J=1,NC IF(MMSOLU.MOTS(I).EQ.NOCOMP(J))THEN IBID(I)=J GO TO 22 ENDIF 25 CONTINUE CALL ERREUR(21) RETURN 22 CONTINUE 20 CONTINUE SEGACT MPOVAL NPN=VPOCHA(/1) C C ON ACTIVE LES SEGMENTS C ET ON DEFINIT LES TABLEAUX DE TRAVAIL SEGACT MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP SEGACT MLIONZ,MLIDP NXDIM=MLIDX.LECT(/1) NYDIM=MLIDY.LECT(/1) NZDIM=MLIDZ.LECT(/1) NPDIM=MLIDP.LECT(/1) SEGINI IDSCHI SEGINI SP2 C JGM=2 JGN=4 SEGINI MLMOTS MOTS(1)='CATI' MOTS(2)='ANIO' CALL CHMCRC(MLMOTS,MELEME,NPN,MCNEUT,ICNEUT) SEGSUP MLMOTS C C INITIALISATION SEGACT MELEME C C ------------------------------------------------------------------- C BOUCLE SUR LES POINTS C ------------------------------------------------------------------- DO 100 II=1,NPN C CHARGEMENT DE IDSCHI CALL CHMIDS(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,MLDECY, * MLNAME,MLIONZ,IDSCHI,MLNESP) C WRITE(6,*)' GK apres CHMIDS ' C WRITE(6,120)(GK(J),IDY(J),J=1,NYDIM) 120 FORMAT(6(1X,1PD12.5,I5)) C CHARGEMENT DE SP2 DO 6 J=1,NXDIM TOT(J)= 0.D0 GX(J)= 0.D0 XX(J)=0.D0 TOTAQ(J)=0.D0 TOTFIX(J)=0.D0 YY(J)=0.D0 6 CONTINUE CALL INITD(GC,NYDIM,0.D0) CALL INITD(CC,NYDIM,0.D0) DO 30 I=1,NSOL CC(I)=VPOCHA(II,IBID(I)) 30 CONTINUE C C= CALCUL DES BILANS C C TC=0.D0 TA=0.D0 L1=NN(1)+NN(2) DO 60 I=1,L1 TW=0.D0 C IF(IDECY(I).EQ.1)GO TO 50 IF(IDECY(I).NE.0)GO TO 50 DO 51 J=1,NXDIM TW=TW+IONZ(J)*AA(I,J) 51 CONTINUE IF (ABS(TW).LT.1.D-10) TW=0.D0 IF (TW.LT.0.D0) TA=TA+TW*CC(I) IF (TW.GT.0.D0) TC=TC+TW*CC(I) 50 CONTINUE 60 CONTINUE ICNEUT.VPOCHA(II,1)= TC ICNEUT.VPOCHA(II,2)= TA 100 CONTINUE C -------------------------------------------------------------- C LE MENAGE C SEGSUP IDSCHI SEGSUP SP2,IZBID C C ON DESACTIVE LES DONNEES SEGDES MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP SEGDES MLIONZ,MLIDP SEGDES MELEME MLENTI=MLCOMP SEGDES MLENTI IF(MLSOSO.NE.0)THEN MLENTI=MLSOSO MLMOTS=MMSOSO SEGDES MLENTI,MLMOTS ENDIF IF(MLPOLE.NE.0)THEN MLENTI=MLPOLE MLMOTS=MMPOLE SEGDES MLENTI,MLMOTS ENDIF IF(MLSOLU.NE.0)THEN MLENTI=MLSOLU MLMOTS=MMSOLU SEGDES MLENTI,MLMOTS ENDIF IF(MLPREC.NE.0)THEN MLENTI=MLPREC MLMOTS=MMPREC SEGDES MLENTI,MLMOTS ENDIF IF(MLSURF.NE.0)THEN MLENTI=MLSURF MLMOTS=MMSURF SEGDES MLENTI,MLMOTS ENDIF IF(MLTYP3.NE.0)THEN MLENTI=MLTYP3 MLMOTS=MMTYP3 SEGDES MLENTI,MLMOTS ENDIF IF(MLTYP6.NE.0)THEN MLENTI=MLTYP6 MLMOTS=MMTYP6 SEGDES MLENTI,MLMOTS ENDIF IF(MLPARF.NE.0)THEN MLENTI=MLPARF SEGDES MLENTI ENDIF IF(MLREAC.NE.0)THEN MLENTI=MLREAC SEGDES MLENTI ENDIF IF(MLIMMO.NE.0)THEN MLENTI=MLIMMO SEGDES MLENTI ENDIF SEGDES MSOUPO,MPOVAL,MCHPOI C C C ON SAUVE LE RESULTAT CALL ECROBJ('CHPOINT',MCNEUT) MSOUPO=MCNEUT.IPCHP(1) SEGDES ICNEUT,MCNEUT,MSOUPO RETURN END