Télécharger neutre.eso

Retour à la liste

Numérotation des lignes :

  1. C NEUTRE SOURCE CHAT 06/03/29 21:27:56 5360
  2. SUBROUTINE NEUTRE
  3. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  4. C
  5. C OPERATEUR NEUT
  6. C
  7. C CALCULE LE BILAN ELECTRIQUE D'UNE SOLUTION CHIMIQUE
  8. C UTILISE LES RESULTATS DE CHI1
  9. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  10. IMPLICIT INTEGER(I-N)
  11. IMPLICIT REAL*8(A-H,O-Z)
  12. -INC CCOPTIO
  13. -INC SMLENTI
  14. -INC SMLMOTS
  15. -INC SMCHPOI
  16. -INC SMELEME
  17. POINTEUR MLAA.MLREEL,MLOGK.MLREEL,MLFF.MLREEL
  18. POINTEUR MLIDX.MLENTI,MLIDY.MLENTI,MLIDZ.MLENTI,MLIDP.MLENTI
  19. POINTEUR MLNN.MLENTI,MLDECY.MLENTI
  20. POINTEUR MLIONZ.MLENTI,MLPREC.MLENTI
  21. POINTEUR MLNAME.MLMOTS,MLNESP.MLMOTS
  22. POINTEUR MLSOLU.MLENTI,MMSOLU.MLMOTS
  23. POINTEUR MCNEUT.MCHPOI,ICNEUT.MPOVAL
  24. CHARACTER*8 TYPEMA
  25. SEGMENT IDSCHI
  26. REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
  27. INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
  28. INTEGER IDECY(NYDIM),IONZ(NXDIM)
  29. CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
  30. ENDSEGMENT
  31. SEGMENT SP2
  32. REAL*8 GX(NXDIM),XX(NXDIM),GS(NZDIM),SS(NZDIM)
  33. REAL*8 TOT(NXDIM),TOTAQ(NXDIM),TOTFIX(NXDIM),GKS(NZDIM)
  34. REAL*8 YY(NXDIM),ZZ(NXDIM,NXDIM),CC(NYDIM),GC(NYDIM)
  35. ENDSEGMENT
  36. SEGMENT IZBID
  37. INTEGER IBID(NSOL)
  38. ENDSEGMENT
  39. C
  40.  
  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 LECTURE DU CHPOIN DES CONCENTRATIONS
  56. C
  57. CALL LIROBJ('CHPOINT',MCHPOI,0,IRETOU)
  58. IF(IRETOU.EQ.0)THEN
  59. CALL ERREUR(21)
  60. RETURN
  61. ENDIF
  62. SEGACT MCHPOI
  63. NSOUPO=IPCHP(/1)
  64. IF(NSOUPO.NE.1)THEN
  65. CALL ERREUR(21)
  66. RETURN
  67. ENDIF
  68. MSOUPO=IPCHP(1)
  69. SEGACT MSOUPO
  70. MELEME=IGEOC
  71. MPOVAL=IPOVAL
  72. NC=NOCOMP(/2)
  73. NSOL=MLSOLU.LECT(/1)
  74. SEGINI IZBID
  75. DO 20 I=1,NSOL
  76. DO 25 J=1,NC
  77. IF(MMSOLU.MOTS(I).EQ.NOCOMP(J))THEN
  78. IBID(I)=J
  79. GO TO 22
  80. ENDIF
  81. 25 CONTINUE
  82. CALL ERREUR(21)
  83. RETURN
  84. 22 CONTINUE
  85. 20 CONTINUE
  86. SEGACT MPOVAL
  87. NPN=VPOCHA(/1)
  88.  
  89. C
  90. C ON ACTIVE LES SEGMENTS
  91. C ET ON DEFINIT LES TABLEAUX DE TRAVAIL
  92. SEGACT MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP
  93. SEGACT MLIONZ,MLIDP
  94. NXDIM=MLIDX.LECT(/1)
  95. NYDIM=MLIDY.LECT(/1)
  96. NZDIM=MLIDZ.LECT(/1)
  97. NPDIM=MLIDP.LECT(/1)
  98. SEGINI IDSCHI
  99. SEGINI SP2
  100. C
  101. JGM=2
  102. JGN=4
  103. SEGINI MLMOTS
  104. MOTS(1)='CATI'
  105. MOTS(2)='ANIO'
  106. CALL CHMCRC(MLMOTS,MELEME,NPN,MCNEUT,ICNEUT)
  107. SEGSUP MLMOTS
  108. C
  109. C INITIALISATION
  110. SEGACT MELEME
  111.  
  112. C
  113. C -------------------------------------------------------------------
  114. C BOUCLE SUR LES POINTS
  115. C -------------------------------------------------------------------
  116. DO 100 II=1,NPN
  117. C CHARGEMENT DE IDSCHI
  118. CALL CHMIDS(MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLIDP,MLNN,MLDECY,
  119. * MLNAME,MLIONZ,IDSCHI,MLNESP)
  120. C WRITE(6,*)' GK apres CHMIDS '
  121. C WRITE(6,120)(GK(J),IDY(J),J=1,NYDIM)
  122. 120 FORMAT(6(1X,1PD12.5,I5))
  123. C CHARGEMENT DE SP2
  124. DO 6 J=1,NXDIM
  125. TOT(J)= 0.D0
  126. GX(J)= 0.D0
  127. XX(J)=0.D0
  128. TOTAQ(J)=0.D0
  129. TOTFIX(J)=0.D0
  130. YY(J)=0.D0
  131. 6 CONTINUE
  132. CALL INITD(GC,NYDIM,0.D0)
  133. CALL INITD(CC,NYDIM,0.D0)
  134. DO 30 I=1,NSOL
  135. CC(I)=VPOCHA(II,IBID(I))
  136. 30 CONTINUE
  137. C
  138. C= CALCUL DES BILANS
  139. C
  140. C
  141. TC=0.D0
  142. TA=0.D0
  143. L1=NN(1)+NN(2)
  144. DO 60 I=1,L1
  145. TW=0.D0
  146. C IF(IDECY(I).EQ.1)GO TO 50
  147. IF(IDECY(I).NE.0)GO TO 50
  148. DO 51 J=1,NXDIM
  149. TW=TW+IONZ(J)*AA(I,J)
  150. 51 CONTINUE
  151.  
  152. IF (ABS(TW).LT.1.D-10) TW=0.D0
  153. IF (TW.LT.0.D0) TA=TA+TW*CC(I)
  154. IF (TW.GT.0.D0) TC=TC+TW*CC(I)
  155. 50 CONTINUE
  156. 60 CONTINUE
  157. ICNEUT.VPOCHA(II,1)= TC
  158. ICNEUT.VPOCHA(II,2)= TA
  159. 100 CONTINUE
  160. C --------------------------------------------------------------
  161. C LE MENAGE
  162. C
  163. SEGSUP IDSCHI
  164. SEGSUP SP2,IZBID
  165. C
  166. C ON DESACTIVE LES DONNEES
  167. SEGDES MLAA,MLOGK,MLFF,MLIDX,MLIDY,MLIDZ,MLNN,MLDECY,MLNAME,MLNESP
  168. SEGDES MLIONZ,MLIDP
  169. SEGDES MELEME
  170. MLENTI=MLCOMP
  171. SEGDES MLENTI
  172. IF(MLSOSO.NE.0)THEN
  173. MLENTI=MLSOSO
  174. MLMOTS=MMSOSO
  175. SEGDES MLENTI,MLMOTS
  176. ENDIF
  177. IF(MLPOLE.NE.0)THEN
  178. MLENTI=MLPOLE
  179. MLMOTS=MMPOLE
  180. SEGDES MLENTI,MLMOTS
  181. ENDIF
  182. IF(MLSOLU.NE.0)THEN
  183. MLENTI=MLSOLU
  184. MLMOTS=MMSOLU
  185. SEGDES MLENTI,MLMOTS
  186. ENDIF
  187. IF(MLPREC.NE.0)THEN
  188. MLENTI=MLPREC
  189. MLMOTS=MMPREC
  190. SEGDES MLENTI,MLMOTS
  191. ENDIF
  192. IF(MLSURF.NE.0)THEN
  193. MLENTI=MLSURF
  194. MLMOTS=MMSURF
  195. SEGDES MLENTI,MLMOTS
  196. ENDIF
  197. IF(MLTYP3.NE.0)THEN
  198. MLENTI=MLTYP3
  199. MLMOTS=MMTYP3
  200. SEGDES MLENTI,MLMOTS
  201. ENDIF
  202. IF(MLTYP6.NE.0)THEN
  203. MLENTI=MLTYP6
  204. MLMOTS=MMTYP6
  205. SEGDES MLENTI,MLMOTS
  206. ENDIF
  207. IF(MLPARF.NE.0)THEN
  208. MLENTI=MLPARF
  209. SEGDES MLENTI
  210. ENDIF
  211. IF(MLREAC.NE.0)THEN
  212. MLENTI=MLREAC
  213. SEGDES MLENTI
  214. ENDIF
  215. IF(MLIMMO.NE.0)THEN
  216. MLENTI=MLIMMO
  217. SEGDES MLENTI
  218. ENDIF
  219. SEGDES MSOUPO,MPOVAL,MCHPOI
  220. C
  221. C
  222. C ON SAUVE LE RESULTAT
  223. CALL ECROBJ('CHPOINT',MCNEUT)
  224. MSOUPO=MCNEUT.IPCHP(1)
  225. SEGDES ICNEUT,MCNEUT,MSOUPO
  226. RETURN
  227. END
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  

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