C LOGK SOURCE CB215821 20/11/25 13:33:58 10792 SUBROUTINE LOGK C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C OPERATEUR LOGK C C CALCULE LA CONSTANTE APPARENTE DE LA LOI D'ACTION C DE MASSE ( DANS UNE SOLUTION CHIMIQUE) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) CHARACTER*8 MOCLE(2) CHARACTER*4 NOMTOT -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,LISCAL.MLENTI POINTEUR MLNAME.MLMOTS,MLNESP.MLMOTS POINTEUR MLSOLU.MLENTI,MMSOLU.MLMOTS POINTEUR MCLOGK.MCHPOI,ICLOGK.MPOVAL POINTEUR MCHTMP.MCHPOI,ICHTMP.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(NLISCA) ENDSEGMENT DATA MOCLE/'FORCEION','TEMPERAT'/ C ICOTY3=0 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 C LECTURE DE LA TABLE TEMPE(SI ELLE EXISTE) C TOUS LES SEGMENTS REVIENNENT ACTIFS OU AVEC UN POINTEUR NUL CALL CHMTET(ITEMPE,LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5) IF(IERR.NE.0)RETURN LTMP=0 IF(LGKMOD.NE.0)LTMP=IP3 C C JCHTMP=0 JCHFIO=0 NPN=0 LISCAL=0 10 CONTINUE IF(LISCAL.EQ.0)THEN ICO1=0 CALL LIROBJ('LISTENTI',LISCAL,ICO1,IRETOU) ENDIF ICOND=0 CALL LIRMOT(MOCLE,2,IRAN,ICOND) IF(IERR.NE.0)RETURN IF(IRAN.EQ.1)THEN C C C LECTURE DU CHPOIN DES FORCES IONIQUES C CALL LIROBJ('CHPOINT',JCHFIO,0,IRETOU) IF(IRETOU.EQ.0)THEN CALL ERREUR(21) RETURN ENDIF MCHPOI=JCHFIO SEGACT MCHPOI NSOUPO=IPCHP(/1) IF(NSOUPO.NE.1)THEN CALL ERREUR(21) RETURN ENDIF MSOUPO=IPCHP(1) SEGACT MSOUPO MELEME=IGEOC MPOVAL=IPOVAL SEGACT MPOVAL NPN=VPOCHA(/1) GO TO 10 ENDIF IF(IRAN.EQ.2)THEN C C C LECTURE DU CHPOIN DES TEMPERATURES C CALL LIROBJ('CHPOINT',JCHTMP,0,IRETOU) IF(IRETOU.EQ.0)THEN CALL ERREUR(21) RETURN ENDIF GO TO 10 ENDIF IF(JCHTMP.NE.0)THEN IF(JCHFIO.NE.0)THEN INDIQ=1 NBCOMP=-1 NOMTOT=' ' CALL QUEPOI(JCHTMP,MELEME,INDIQ,NBCOMP,NOMTOT) IF(INDIQ.LT.0)THEN CALL ERREUR(22) ENDIF IF(IERR.NE.0)RETURN ENDIF MCHTMP=JCHTMP CALL LICHT(MCHTMP,ICHTMP,TYPEMA,IGEOM) NPN=ICHTMP.VPOCHA(/1) MELEME=IGEOM ENDIF IF(NPN.EQ.0)THEN CALL ERREUR(641) RETURN ENDIF 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 C LE CHPOINT RESULTAT JGM=NYDIM JGN=4 IF(LISCAL.NE.0)THEN SEGACT LISCAL JGM=LISCAL.LECT(/1) ENDIF NLISCA=JGM SEGINI MLMOTS,IZBID IF(LISCAL.EQ.0)THEN DO 11 I=1,NYDIM IBID(I)=I 11 CONTINUE ELSE DO 12 I=1,NLISCA DO 13 J=1,NYDIM IF(LISCAL.LECT(I).EQ.MLIDY.LECT(J))THEN IBID(I)=J GO TO 14 ENDIF 13 CONTINUE CALL ERREUR(21) RETURN 14 CONTINUE 12 CONTINUE ENDIF 110 FORMAT('W',I3.3) DO 15 I=1,NLISCA WRITE(MOTS(I),110)IBID(I) 15 CONTINUE CALL CHMCRC(MLMOTS,MELEME,NPN,MCLOGK,ICLOGK) 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 EVENTUEL DE LGKMOD OU LGKTMP CALL CHMLGK(LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5) C XMU=0.D0 XMUNEW=0.D0 IF(JCHFIO.NE.0)THEN XMUNEW=VPOCHA(II,1) ENDIF TMP=25.D0 TMPNEW=25.D0 IF(JCHTMP.NE.0)TMPNEW=ICHTMP.VPOCHA(II,1) CALL CHMKMD(IDSCHI,LGKMOD,LGKTMP,ICOTY3,LTMP,TMP,TMPNEW, * XMU,XMUNEW,GNEW) DO 95 J=1,NLISCA ICLOGK.VPOCHA(II,J)=GK(IBID(J)) 95 CONTINUE 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 IF(JCHTMP.NE.0)THEN SEGDES ICHTMP ENDIF IF(JCHFIO.NE.0)THEN SEGDES MSOUPO,MPOVAL,MCHPOI ENDIF IF(LISCAL.NE.0)THEN SEGDES LISCAL ENDIF CALL CHMDGK(LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5) C C ON SAUVE LE RESULTAT CALL ECROBJ('CHPOINT',MCLOGK) MSOUPO=MCLOGK.IPCHP(1) SEGDES ICLOGK,MCLOGK,MSOUPO RETURN END