Télécharger la plaquette Cast3M


fr en

Télécharger logk.eso

Retour à la liste

Numérotation des lignes : 

logk

  1. C LOGK      SOURCE    CB215821  20/11/25    13:33:58     10792          
  2.       SUBROUTINE LOGK
  3. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  4. C
  5. C               OPERATEUR LOGK
  6. C
  7. C           CALCULE LA CONSTANTE APPARENTE DE LA LOI D'ACTION
  8. C          DE MASSE ( DANS UNE SOLUTION CHIMIQUE)
  9. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  10.       IMPLICIT INTEGER(I-N)
  11.       IMPLICIT REAL*8(A-H,O-Z)
  12.       CHARACTER*8 MOCLE(2)
  13.       CHARACTER*4 NOMTOT
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMLENTI
  18. -INC SMLMOTS
  19. -INC SMCHPOI
  20. -INC SMELEME
  21.       POINTEUR MLAA.MLREEL,MLOGK.MLREEL,MLFF.MLREEL
  22.       POINTEUR MLIDX.MLENTI,MLIDY.MLENTI,MLIDZ.MLENTI,MLIDP.MLENTI
  23.       POINTEUR MLNN.MLENTI,MLDECY.MLENTI
  24.       POINTEUR MLIONZ.MLENTI,MLPREC.MLENTI,LISCAL.MLENTI
  25.       POINTEUR MLNAME.MLMOTS,MLNESP.MLMOTS
  26.       POINTEUR MLSOLU.MLENTI,MMSOLU.MLMOTS
  27.       POINTEUR MCLOGK.MCHPOI,ICLOGK.MPOVAL
  28.       POINTEUR MCHTMP.MCHPOI,ICHTMP.MPOVAL
  29.       CHARACTER*8 TYPEMA
  30.       SEGMENT IDSCHI
  31.            REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
  32.            INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
  33.            INTEGER IDECY(NYDIM),IONZ(NXDIM)
  34.            CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
  35.       ENDSEGMENT
  36.       SEGMENT SP2
  37.            REAL*8 GX(NXDIM),XX(NXDIM),GS(NZDIM),SS(NZDIM)
  38.            REAL*8 TOT(NXDIM),TOTAQ(NXDIM),TOTFIX(NXDIM),GKS(NZDIM)
  39.            REAL*8 YY(NXDIM),ZZ(NXDIM,NXDIM),CC(NYDIM),GC(NYDIM)
  40.       ENDSEGMENT
  41.       SEGMENT IZBID
  42.            INTEGER IBID(NLISCA)
  43.       ENDSEGMENT
  44.       DATA MOCLE/'FORCEION','TEMPERAT'/
  45. C
  46.  
  47.       ICOTY3=0
  48. C
  49. C                       LECTURE DE LA TABLE CHIMI1
  50.       CALL CHMDEB(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,MLDECY,
  51.      * MLNAME,MLIONZ,ITIDEN,ITREDO,ITEMPE,MLNESP)
  52.       IF(IERR.NE.0)RETURN
  53. C
  54. C                 LECTURE DE LA TABLE IDEN
  55. C      TOUS LES SEGMENTS REVIENNENT ACTIFS OU AVEC UN POINTEUR NUL
  56. C
  57.       CALL CHMIDE(ITIDEN,MLCOMP,MLSOLU,MMSOLU,MLPREC,MMPREC,MLSURF,
  58.      *     MMSURF,MLTYP3,MMTYP3,MLTYP6,MMTYP6,MLPARF,MLREAC,MLIMMO,
  59.      *     MLPOLE,MMPOLE,MLSOSO,MMSOSO,LIMP3)
  60.        IF(IERR.NE.0)RETURN
  61. C
  62. C
  63. C                         LECTURE DE LA TABLE TEMPE(SI ELLE EXISTE)
  64. C      TOUS LES SEGMENTS REVIENNENT ACTIFS OU AVEC UN POINTEUR NUL
  65.       CALL CHMTET(ITEMPE,LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5)
  66.       IF(IERR.NE.0)RETURN
  67.       LTMP=0
  68.       IF(LGKMOD.NE.0)LTMP=IP3
  69. C
  70. C
  71.       JCHTMP=0
  72.       JCHFIO=0
  73.       NPN=0
  74.       LISCAL=0
  75.    10 CONTINUE
  76.       IF(LISCAL.EQ.0)THEN
  77.       ICO1=0
  78.       CALL LIROBJ('LISTENTI',LISCAL,ICO1,IRETOU)
  79.       ENDIF
  80.       ICOND=0
  81.       CALL LIRMOT(MOCLE,2,IRAN,ICOND)
  82.       IF(IERR.NE.0)RETURN
  83.       IF(IRAN.EQ.1)THEN
  84. C
  85. C
  86. C       LECTURE DU CHPOIN DES FORCES IONIQUES
  87. C
  88.       CALL LIROBJ('CHPOINT',JCHFIO,0,IRETOU)
  89.       IF(IRETOU.EQ.0)THEN
  90.       CALL ERREUR(21)
  91.       RETURN
  92.       ENDIF
  93.       MCHPOI=JCHFIO
  94.       SEGACT MCHPOI
  95.       NSOUPO=IPCHP(/1)
  96.       IF(NSOUPO.NE.1)THEN
  97.            CALL ERREUR(21)
  98.             RETURN
  99.       ENDIF
  100.       MSOUPO=IPCHP(1)
  101.       SEGACT MSOUPO
  102.       MELEME=IGEOC
  103.       MPOVAL=IPOVAL
  104.       SEGACT MPOVAL
  105.       NPN=VPOCHA(/1)
  106.       GO TO 10
  107.       ENDIF
  108.       IF(IRAN.EQ.2)THEN
  109. C
  110. C
  111. C       LECTURE DU CHPOIN DES TEMPERATURES
  112. C
  113.       CALL LIROBJ('CHPOINT',JCHTMP,0,IRETOU)
  114.       IF(IRETOU.EQ.0)THEN
  115.             CALL ERREUR(21)
  116.             RETURN
  117.       ENDIF
  118.       GO TO 10
  119.       ENDIF
  120.       IF(JCHTMP.NE.0)THEN
  121.       IF(JCHFIO.NE.0)THEN
  122.             INDIQ=1
  123.             NBCOMP=-1
  124.             NOMTOT='    '
  125.             CALL QUEPOI(JCHTMP,MELEME,INDIQ,NBCOMP,NOMTOT)
  126.             IF(INDIQ.LT.0)THEN
  127.                  CALL ERREUR(22)
  128.             ENDIF
  129.             IF(IERR.NE.0)RETURN
  130.             ENDIF
  131.             MCHTMP=JCHTMP
  132.             CALL LICHT(MCHTMP,ICHTMP,TYPEMA,IGEOM)
  133.             NPN=ICHTMP.VPOCHA(/1)
  134.             MELEME=IGEOM
  135.       ENDIF
  136.       IF(NPN.EQ.0)THEN
  137.             CALL ERREUR(641)
  138.             RETURN
  139.       ENDIF
  140. C
  141. C                         ON ACTIVE LES SEGMENTS
  142. C              ET ON DEFINIT LES TABLEAUX DE TRAVAIL
  143.       SEGACT MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP
  144.       SEGACT MLIONZ,MLIDP
  145.       NXDIM=MLIDX.LECT(/1)
  146.       NYDIM=MLIDY.LECT(/1)
  147.       NZDIM=MLIDZ.LECT(/1)
  148.       NPDIM=MLIDP.LECT(/1)
  149.       SEGINI IDSCHI
  150.       SEGINI SP2
  151. C
  152. C                           LE CHPOINT RESULTAT
  153.       JGM=NYDIM
  154.       JGN=4
  155.       IF(LISCAL.NE.0)THEN
  156.             SEGACT LISCAL
  157.             JGM=LISCAL.LECT(/1)
  158.       ENDIF
  159.       NLISCA=JGM
  160.       SEGINI MLMOTS,IZBID
  161.       IF(LISCAL.EQ.0)THEN
  162.              DO 11 I=1,NYDIM
  163.                    IBID(I)=I
  164.    11        CONTINUE
  165.       ELSE
  166.              DO 12 I=1,NLISCA
  167.                  DO 13 J=1,NYDIM
  168.                        IF(LISCAL.LECT(I).EQ.MLIDY.LECT(J))THEN
  169.                             IBID(I)=J
  170.                             GO TO 14
  171.                        ENDIF
  172.    13            CONTINUE
  173.                  CALL ERREUR(21)
  174.                  RETURN
  175.    14            CONTINUE
  176.    12        CONTINUE
  177.       ENDIF
  178.   110 FORMAT('W',I3.3)
  179.       DO 15 I=1,NLISCA
  180.       WRITE(MOTS(I),110)IBID(I)
  181.    15 CONTINUE
  182.       CALL CHMCRC(MLMOTS,MELEME,NPN,MCLOGK,ICLOGK)
  183.       SEGSUP MLMOTS
  184. C
  185. C                           INITIALISATION
  186.       SEGACT MELEME
  187.  
  188. C
  189. C -------------------------------------------------------------------
  190. C                         BOUCLE SUR LES POINTS
  191. C -------------------------------------------------------------------
  192.       DO 100 II=1,NPN
  193. C                   CHARGEMENT DE IDSCHI
  194.       CALL CHMIDS(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,MLDECY,
  195.      * MLNAME,MLIONZ,IDSCHI,MLNESP)
  196. C     WRITE(6,*)' GK apres CHMIDS '
  197. C     WRITE(6,120)(GK(J),IDY(J),J=1,NYDIM)
  198.   120 FORMAT(6(1X,1PD12.5,I5))
  199. C                   CHARGEMENT EVENTUEL DE LGKMOD OU LGKTMP
  200.       CALL CHMLGK(LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5)
  201. C
  202.       XMU=0.D0
  203.       XMUNEW=0.D0
  204.       IF(JCHFIO.NE.0)THEN
  205.             XMUNEW=VPOCHA(II,1)
  206.       ENDIF
  207.       TMP=25.D0
  208.       TMPNEW=25.D0
  209.       IF(JCHTMP.NE.0)TMPNEW=ICHTMP.VPOCHA(II,1)
  210.       CALL CHMKMD(IDSCHI,LGKMOD,LGKTMP,ICOTY3,LTMP,TMP,TMPNEW,
  211.      * XMU,XMUNEW,GNEW)
  212.       DO 95 J=1,NLISCA
  213.             ICLOGK.VPOCHA(II,J)=GK(IBID(J))
  214.    95 CONTINUE
  215.   100 CONTINUE
  216. C   --------------------------------------------------------------
  217. C                      LE MENAGE
  218. C
  219.       SEGSUP IDSCHI
  220.       SEGSUP SP2,IZBID
  221. C
  222. C                   ON DESACTIVE LES DONNEES
  223.       SEGDES MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP
  224.        SEGDES MLIONZ,MLIDP
  225.       SEGDES MELEME
  226.        MLENTI=MLCOMP
  227.        SEGDES MLENTI
  228.        IF(MLSOSO.NE.0)THEN
  229.           MLENTI=MLSOSO
  230.           MLMOTS=MMSOSO
  231.           SEGDES MLENTI,MLMOTS
  232.        ENDIF
  233.        IF(MLPOLE.NE.0)THEN
  234.           MLENTI=MLPOLE
  235.           MLMOTS=MMPOLE
  236.           SEGDES MLENTI,MLMOTS
  237.        ENDIF
  238.        IF(MLSOLU.NE.0)THEN
  239.              MLENTI=MLSOLU
  240.              MLMOTS=MMSOLU
  241.              SEGDES MLENTI,MLMOTS
  242.        ENDIF
  243.        IF(MLPREC.NE.0)THEN
  244.              MLENTI=MLPREC
  245.              MLMOTS=MMPREC
  246.              SEGDES MLENTI,MLMOTS
  247.        ENDIF
  248.        IF(MLSURF.NE.0)THEN
  249.              MLENTI=MLSURF
  250.              MLMOTS=MMSURF
  251.              SEGDES MLENTI,MLMOTS
  252.        ENDIF
  253.        IF(MLTYP3.NE.0)THEN
  254.              MLENTI=MLTYP3
  255.              MLMOTS=MMTYP3
  256.              SEGDES MLENTI,MLMOTS
  257.        ENDIF
  258.        IF(MLTYP6.NE.0)THEN
  259.              MLENTI=MLTYP6
  260.              MLMOTS=MMTYP6
  261.              SEGDES MLENTI,MLMOTS
  262.        ENDIF
  263.        IF(MLPARF.NE.0)THEN
  264.              MLENTI=MLPARF
  265.              SEGDES MLENTI
  266.        ENDIF
  267.        IF(MLREAC.NE.0)THEN
  268.              MLENTI=MLREAC
  269.              SEGDES MLENTI
  270.        ENDIF
  271.        IF(MLIMMO.NE.0)THEN
  272.              MLENTI=MLIMMO
  273.              SEGDES MLENTI
  274.        ENDIF
  275.       IF(JCHTMP.NE.0)THEN
  276.              SEGDES ICHTMP
  277.       ENDIF
  278.       IF(JCHFIO.NE.0)THEN
  279.             SEGDES MSOUPO,MPOVAL,MCHPOI
  280.       ENDIF
  281.       IF(LISCAL.NE.0)THEN
  282.             SEGDES LISCAL
  283.       ENDIF
  284.       CALL CHMDGK(LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5)
  285. C
  286. C                   ON SAUVE LE RESULTAT
  287.       CALL ECROBJ('CHPOINT',MCLOGK)
  288.       MSOUPO=MCLOGK.IPCHP(1)
  289.       SEGDES ICLOGK,MCLOGK,MSOUPO
  290.       RETURN
  291.       END
  292.  
  293.  
  294.  
  295.  
  296.  
  297.  
  298.  
  299.  
  300.  
  301.  
  302.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales