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

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