Sources Esope | Cast3M

coac
C COAC      SOURCE    CB215821  20/11/25    13:21:36     10792          
      SUBROUTINE COAC
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C               OPERATEUR COAC
C
C   CALCULE LE COEFFICIENT D'ACTIVITE ( DANS UNE SOLUTION CHIMIQUE)
C
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
      POINTEUR MLNAME.MLMOTS,MLNESP.MLMOTS
      POINTEUR MLSOLU.MLENTI,MMSOLU.MLMOTS
      POINTEUR MCOACT.MCHPOI,ICOACT.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
      DATA MOCLE/'FORCEION','TEMPERAT'/
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
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
      ILIR=1
   10 CONTINUE
      ICOND=ILIR
      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 ',MCHPOI,1,IRETOU)
      CALL ACTOBJ('CHPOINT ',MCHPOI,1)
      IF(IERR.NE.0)RETURN
      NSOUPO=IPCHP(/1)
      IF(NSOUPO.NE.1)THEN
           CALL ERREUR(21)
            RETURN
      ENDIF
      ILIR=ILIR-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)
      CALL ACTOBJ('CHPOINT ',JCHTMP,1)
      IF(IERR.NE.0)RETURN
      GO TO 10
      ENDIF
      MSOUPO=IPCHP(1)
      MELEME=IGEOC
      IF(JCHTMP.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
            MCHTMP=JCHTMP
            CALL LICHT(MCHTMP,ICHTMP,TYPEMA,IGEOM)
      ENDIF
      MPOVAL=IPOVAL
      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
C                           LE CHPOINT RESULTAT
      JGM=1
      JGN=4
      SEGINI MLMOTS
      MOTS(1)='SCAL'
      CALL CHMCRC(MLMOTS,MELEME,NPN,MCOACT,ICOACT)
      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
      XMU=0.D0
      XMUNEW=VPOCHA(II,1)
      TMP=25.D0
      TMPNEW=25.D0
      IF(JCHTMP.NE.0)TMPNEW=ICHTMP.VPOCHA(II,1)
            CALL  CHMMOD(IDSCHI,XMU,XMUNEW,TMPNEW,GNEW)
       ICOACT.VPOCHA(II,1)=GNEW
  100 CONTINUE
C   --------------------------------------------------------------
C                      LE MENAGE
C
      SEGSUP IDSCHI
      SEGSUP SP2
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
      CALL CHMDGK(LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5)
C
C                   ON SAUVE LE RESULTAT
      CALL ACTOBJ('CHPOINT ',MCOACT,1)
      CALL ECROBJ('CHPOINT ',MCOACT)
      END