Télécharger coac.eso

Retour à la liste

Numérotation des lignes :

  1. C COAC SOURCE CHAT 06/03/29 21:17:03 5360
  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,0,IRETOU)
  76. IF(IRETOU.EQ.0)THEN
  77. CALL ERREUR(21)
  78. RETURN
  79. ENDIF
  80. SEGACT MCHPOI
  81. NSOUPO=IPCHP(/1)
  82. IF(NSOUPO.NE.1)THEN
  83. CALL ERREUR(21)
  84. RETURN
  85. ENDIF
  86. ILIR=ILIR-1
  87. GO TO 10
  88. ENDIF
  89. IF(IRAN.EQ.2)THEN
  90. C
  91. C
  92. C LECTURE DU CHPOIN DES TEMPERATURES
  93. C
  94. CALL LIROBJ('CHPOINT',JCHTMP,0,IRETOU)
  95. IF(IRETOU.EQ.0)THEN
  96. CALL ERREUR(21)
  97. RETURN
  98. ENDIF
  99. GO TO 10
  100. ENDIF
  101. MSOUPO=IPCHP(1)
  102. SEGACT MSOUPO
  103. MELEME=IGEOC
  104. IF(JCHTMP.NE.0)THEN
  105. INDIQ=1
  106. NBCOMP=-1
  107. NOMTOT=' '
  108. CALL QUEPOI(JCHTMP,MELEME,INDIQ,NBCOMP,NOMTOT)
  109. IF(INDIQ.LT.0)THEN
  110. CALL ERREUR(22)
  111. ENDIF
  112. IF(IERR.NE.0)RETURN
  113. MCHTMP=JCHTMP
  114. CALL LICHT(MCHTMP,ICHTMP,TYPEMA,IGEOM)
  115. ENDIF
  116. MPOVAL=IPOVAL
  117. SEGACT MPOVAL
  118. NPN=VPOCHA(/1)
  119.  
  120. C
  121. C ON ACTIVE LES SEGMENTS
  122. C ET ON DEFINIT LES TABLEAUX DE TRAVAIL
  123. SEGACT MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP
  124. SEGACT MLIONZ,MLIDP
  125. NXDIM=MLIDX.LECT(/1)
  126. NYDIM=MLIDY.LECT(/1)
  127. NZDIM=MLIDZ.LECT(/1)
  128. NPDIM=MLIDP.LECT(/1)
  129. SEGINI IDSCHI
  130. SEGINI SP2
  131. C
  132. C LE CHPOINT RESULTAT
  133. JGM=1
  134. JGN=4
  135. SEGINI MLMOTS
  136. MOTS(1)='SCAL'
  137. CALL CHMCRC(MLMOTS,MELEME,NPN,MCOACT,ICOACT)
  138. SEGSUP MLMOTS
  139. C
  140. C INITIALISATION
  141. SEGACT MELEME
  142.  
  143. C
  144. C -------------------------------------------------------------------
  145. C BOUCLE SUR LES POINTS
  146. C -------------------------------------------------------------------
  147. DO 100 II=1,NPN
  148. C CHARGEMENT DE IDSCHI
  149. CALL CHMIDS(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,MLDECY,
  150. * MLNAME,MLIONZ,IDSCHI,MLNESP)
  151. C WRITE(6,*)' GK apres CHMIDS '
  152. C WRITE(6,120)(GK(J),IDY(J),J=1,NYDIM)
  153. 120 FORMAT(6(1X,1PD12.5,I5))
  154. C
  155. XMU=0.D0
  156. XMUNEW=VPOCHA(II,1)
  157. TMP=25.D0
  158. TMPNEW=25.D0
  159. IF(JCHTMP.NE.0)TMPNEW=ICHTMP.VPOCHA(II,1)
  160. CALL CHMMOD(IDSCHI,XMU,XMUNEW,TMPNEW,GNEW)
  161. ICOACT.VPOCHA(II,1)=GNEW
  162. 100 CONTINUE
  163. C --------------------------------------------------------------
  164. C LE MENAGE
  165. C
  166. SEGSUP IDSCHI
  167. SEGSUP SP2
  168. C
  169. C ON DESACTIVE LES DONNEES
  170. SEGDES MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP
  171. SEGDES MLIONZ,MLIDP
  172. SEGDES MELEME
  173. MLENTI=MLCOMP
  174. SEGDES MLENTI
  175. IF(MLSOSO.NE.0)THEN
  176. MLENTI=MLSOSO
  177. MLMOTS=MMSOSO
  178. SEGDES MLENTI,MLMOTS
  179. ENDIF
  180. IF(MLPOLE.NE.0)THEN
  181. MLENTI=MLPOLE
  182. MLMOTS=MMPOLE
  183. SEGDES MLENTI,MLMOTS
  184. ENDIF
  185. IF(MLSOLU.NE.0)THEN
  186. MLENTI=MLSOLU
  187. MLMOTS=MMSOLU
  188. SEGDES MLENTI,MLMOTS
  189. ENDIF
  190. IF(MLPREC.NE.0)THEN
  191. MLENTI=MLPREC
  192. MLMOTS=MMPREC
  193. SEGDES MLENTI,MLMOTS
  194. ENDIF
  195. IF(MLSURF.NE.0)THEN
  196. MLENTI=MLSURF
  197. MLMOTS=MMSURF
  198. SEGDES MLENTI,MLMOTS
  199. ENDIF
  200. IF(MLTYP3.NE.0)THEN
  201. MLENTI=MLTYP3
  202. MLMOTS=MMTYP3
  203. SEGDES MLENTI,MLMOTS
  204. ENDIF
  205. IF(MLTYP6.NE.0)THEN
  206. MLENTI=MLTYP6
  207. MLMOTS=MMTYP6
  208. SEGDES MLENTI,MLMOTS
  209. ENDIF
  210. IF(MLPARF.NE.0)THEN
  211. MLENTI=MLPARF
  212. SEGDES MLENTI
  213. ENDIF
  214. IF(MLREAC.NE.0)THEN
  215. MLENTI=MLREAC
  216. SEGDES MLENTI
  217. ENDIF
  218. IF(MLIMMO.NE.0)THEN
  219. MLENTI=MLIMMO
  220. SEGDES MLENTI
  221. ENDIF
  222. IF(JCHTMP.NE.0)THEN
  223. SEGDES ICHTMP
  224. ENDIF
  225. SEGDES MSOUPO,MPOVAL,MCHPOI
  226. CALL CHMDGK(LGKMOD,LGKTMP,IP1,IP2,IP3,IP4,IP5)
  227. C
  228. C ON SAUVE LE RESULTAT
  229. CALL ECROBJ('CHPOINT',MCOACT)
  230. MSOUPO=MCOACT.IPCHP(1)
  231. SEGDES ICOACT,MCOACT,MSOUPO
  232. RETURN
  233. END
  234.  
  235.  
  236.  
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  

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