Télécharger coac.eso

Retour à la liste

Numérotation des lignes :

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

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