Télécharger coac.eso

Retour à la liste

Numérotation des lignes :

coac
  1. C COAC SOURCE CB215821 20/11/25 13:21:36 10792
  2. SUBROUTINE COAC
  3. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  4. C
  5. C OPERATEUR COAC
  6. C
  7. C CALCULE LE COEFFICIENT D'ACTIVITE ( DANS UNE SOLUTION CHIMIQUE)
  8. C
  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
  25. POINTEUR MLNAME.MLMOTS,MLNESP.MLMOTS
  26. POINTEUR MLSOLU.MLENTI,MMSOLU.MLMOTS
  27. POINTEUR MCOACT.MCHPOI,ICOACT.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. DATA MOCLE/'FORCEION','TEMPERAT'/
  42. C
  43. C
  44. C LECTURE DE LA TABLE CHIMI1
  45. CALL CHMDEB(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,MLDECY,
  46. * MLNAME,MLIONZ,ITIDEN,ITREDO,ITEMPE,MLNESP)
  47. IF(IERR.NE.0)RETURN
  48. C
  49. C LECTURE DE LA TABLE IDEN
  50. C TOUS LES SEGMENTS REVIENNENT ACTIFS OU AVEC UN POINTEUR NUL
  51. C
  52. CALL CHMIDE(ITIDEN,MLCOMP,MLSOLU,MMSOLU,MLPREC,MMPREC,MLSURF,
  53. * MMSURF,MLTYP3,MMTYP3,MLTYP6,MMTYP6,MLPARF,MLREAC,MLIMMO,
  54. * MLPOLE,MMPOLE,MLSOSO,MMSOSO,LIMP3)
  55. IF(IERR.NE.0)RETURN
  56. C
  57. C
  58. C LECTURE DE LA TABLE TEMPE(SI ELLE EXISTE)
  59. C TOUS LES SEGMENTS REVIENNENT ACTIFS OU AVEC UN POINTEUR NUL
  60. CALL CHMTET(ITEMPE,LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5)
  61. IF(IERR.NE.0)RETURN
  62. LTMP=0
  63. IF(LGKMOD.NE.0)LTMP=IP3
  64. C
  65. C
  66. JCHTMP=0
  67. ILIR=1
  68. 10 CONTINUE
  69. ICOND=ILIR
  70. CALL LIRMOT(MOCLE,2,IRAN,ICOND)
  71. IF(IERR.NE.0)RETURN
  72. IF(IRAN.EQ.1)THEN
  73. C
  74. C
  75. C LECTURE DU CHPOIN DES FORCES IONIQUES
  76. C
  77. CALL LIROBJ('CHPOINT ',MCHPOI,1,IRETOU)
  78. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  79. IF(IERR.NE.0)RETURN
  80. NSOUPO=IPCHP(/1)
  81. IF(NSOUPO.NE.1)THEN
  82. CALL ERREUR(21)
  83. RETURN
  84. ENDIF
  85. ILIR=ILIR-1
  86. GO TO 10
  87. ENDIF
  88. IF(IRAN.EQ.2)THEN
  89. C
  90. C
  91. C LECTURE DU CHPOIN DES TEMPERATURES
  92. C
  93. CALL LIROBJ('CHPOINT ',JCHTMP,0,IRETOU)
  94. CALL ACTOBJ('CHPOINT ',JCHTMP,1)
  95. IF(IERR.NE.0)RETURN
  96. GO TO 10
  97. ENDIF
  98. MSOUPO=IPCHP(1)
  99. MELEME=IGEOC
  100. IF(JCHTMP.NE.0)THEN
  101. INDIQ=1
  102. NBCOMP=-1
  103. NOMTOT=' '
  104. CALL QUEPOI(JCHTMP,MELEME,INDIQ,NBCOMP,NOMTOT)
  105. IF(INDIQ.LT.0)THEN
  106. CALL ERREUR(22)
  107. ENDIF
  108. IF(IERR.NE.0)RETURN
  109. MCHTMP=JCHTMP
  110. CALL LICHT(MCHTMP,ICHTMP,TYPEMA,IGEOM)
  111. ENDIF
  112. MPOVAL=IPOVAL
  113. NPN=VPOCHA(/1)
  114.  
  115. C
  116. C ON ACTIVE LES SEGMENTS
  117. C ET ON DEFINIT LES TABLEAUX DE TRAVAIL
  118. SEGACT MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP
  119. SEGACT MLIONZ,MLIDP
  120. NXDIM=MLIDX.LECT(/1)
  121. NYDIM=MLIDY.LECT(/1)
  122. NZDIM=MLIDZ.LECT(/1)
  123. NPDIM=MLIDP.LECT(/1)
  124. SEGINI IDSCHI
  125. SEGINI SP2
  126. C
  127. C LE CHPOINT RESULTAT
  128. JGM=1
  129. JGN=4
  130. SEGINI MLMOTS
  131. MOTS(1)='SCAL'
  132. CALL CHMCRC(MLMOTS,MELEME,NPN,MCOACT,ICOACT)
  133. SEGSUP MLMOTS
  134. C
  135. C INITIALISATION
  136. SEGACT MELEME
  137.  
  138. C
  139. C -------------------------------------------------------------------
  140. C BOUCLE SUR LES POINTS
  141. C -------------------------------------------------------------------
  142. DO 100 II=1,NPN
  143. C CHARGEMENT DE IDSCHI
  144. CALL CHMIDS(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,MLDECY,
  145. * MLNAME,MLIONZ,IDSCHI,MLNESP)
  146. C WRITE(6,*)' GK apres CHMIDS '
  147. C WRITE(6,120)(GK(J),IDY(J),J=1,NYDIM)
  148. 120 FORMAT(6(1X,1PD12.5,I5))
  149. C
  150. XMU=0.D0
  151. XMUNEW=VPOCHA(II,1)
  152. TMP=25.D0
  153. TMPNEW=25.D0
  154. IF(JCHTMP.NE.0)TMPNEW=ICHTMP.VPOCHA(II,1)
  155. CALL CHMMOD(IDSCHI,XMU,XMUNEW,TMPNEW,GNEW)
  156. ICOACT.VPOCHA(II,1)=GNEW
  157. 100 CONTINUE
  158. C --------------------------------------------------------------
  159. C LE MENAGE
  160. C
  161. SEGSUP IDSCHI
  162. SEGSUP SP2
  163. C
  164. C ON DESACTIVE LES DONNEES
  165. SEGDES MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP
  166. SEGDES MLIONZ,MLIDP
  167. SEGDES MELEME
  168. MLENTI=MLCOMP
  169. SEGDES MLENTI
  170. IF(MLSOSO.NE.0)THEN
  171. MLENTI=MLSOSO
  172. MLMOTS=MMSOSO
  173. SEGDES MLENTI,MLMOTS
  174. ENDIF
  175. IF(MLPOLE.NE.0)THEN
  176. MLENTI=MLPOLE
  177. MLMOTS=MMPOLE
  178. SEGDES MLENTI,MLMOTS
  179. ENDIF
  180. IF(MLSOLU.NE.0)THEN
  181. MLENTI=MLSOLU
  182. MLMOTS=MMSOLU
  183. SEGDES MLENTI,MLMOTS
  184. ENDIF
  185. IF(MLPREC.NE.0)THEN
  186. MLENTI=MLPREC
  187. MLMOTS=MMPREC
  188. SEGDES MLENTI,MLMOTS
  189. ENDIF
  190. IF(MLSURF.NE.0)THEN
  191. MLENTI=MLSURF
  192. MLMOTS=MMSURF
  193. SEGDES MLENTI,MLMOTS
  194. ENDIF
  195. IF(MLTYP3.NE.0)THEN
  196. MLENTI=MLTYP3
  197. MLMOTS=MMTYP3
  198. SEGDES MLENTI,MLMOTS
  199. ENDIF
  200. IF(MLTYP6.NE.0)THEN
  201. MLENTI=MLTYP6
  202. MLMOTS=MMTYP6
  203. SEGDES MLENTI,MLMOTS
  204. ENDIF
  205. IF(MLPARF.NE.0)THEN
  206. MLENTI=MLPARF
  207. SEGDES MLENTI
  208. ENDIF
  209. IF(MLREAC.NE.0)THEN
  210. MLENTI=MLREAC
  211. SEGDES MLENTI
  212. ENDIF
  213. IF(MLIMMO.NE.0)THEN
  214. MLENTI=MLIMMO
  215. SEGDES MLENTI
  216. ENDIF
  217. IF(JCHTMP.NE.0)THEN
  218. SEGDES ICHTMP
  219. ENDIF
  220. CALL CHMDGK(LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5)
  221. C
  222. C ON SAUVE LE RESULTAT
  223. CALL ACTOBJ('CHPOINT ',MCOACT,1)
  224. CALL ECROBJ('CHPOINT ',MCOACT)
  225. END
  226.  
  227.  
  228.  
  229.  

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