Télécharger biokam.eso

Retour à la liste

Numérotation des lignes :

  1. C BIOKAM SOURCE CHAT 05/01/12 21:40:13 5004
  2. SUBROUTINE BIOKAM(MCHPO1,IPT1,ENT)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. -INC CCOPTIO
  6. -INC CCREEL
  7. -INC SMELEME
  8. -INC SMCOORD
  9. -INC SMCHPOI
  10. -INC TMTRAV
  11. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  12. SEGMENT STAB
  13. REAL*8 ICOS(INMAX), INTELL(INM,6)
  14. END SEGMENT
  15. INTEGER ENTIER,ENT,I,IVAL,NMAX,NM
  16. character*4 ichaine
  17. DIMENSION TAB1(101),TAB2(101)
  18.  
  19. NMAX=50
  20. NM=99
  21. NE=NM+1
  22.  
  23. C============================================
  24. C ON COMMENCE PAR EXPLORER LE MAILLAGE =
  25. C============================================
  26. SEGACT IPT1
  27. IF (IPT1.ITYPEL.NE.1.OR.IPT1.LISOUS(/1).NE.0) CALL CHANGE(IPT1,1)
  28.  
  29. C==============================================================
  30. C ON VERIFIE QUE CHAQUE POINT N'APPARAIT QU'UNE SEULE FOIS =
  31. C==============================================================
  32.  
  33. NNNOE=IPT1.NUM(/2)
  34. SEGINI ICPR
  35. ICON=0
  36. DO 1 I=1,NNNOE
  37. IKI=IPT1.NUM(1,I)
  38. IF(ICPR(IKI).NE.0) GO TO 1
  39. ICON=ICON+1
  40. ICPR(IKI)=ICON
  41. 1 CONTINUE
  42. SEGSUP ICPR
  43.  
  44. IF(ICON.NE.NNNOE) THEN
  45. CALL ERREUR(75)
  46. SEGDES IPT1
  47. RETURN
  48. ENDIF
  49.  
  50.  
  51.  
  52. C===========================================
  53. C INITIALISATION DES NOMS DES COMPOSANTES =
  54. C===========================================
  55.  
  56. NNIN=IDIM+1
  57. SEGINI MTRAV
  58. NHRM=NIFOUR
  59. IF (NIFOUR.EQ.1) NHRM=IFOUR
  60. INCO(1)='BX '
  61. INCO(2)='BY '
  62. INCO(3)='BZ '
  63. INCO(4)='FLUX'
  64. NHAR(1)=NHRM
  65. NHAR(2)=NHRM
  66. NHAR(3)=NHRM
  67. NHAR(4)=NHRM
  68.  
  69.  
  70. C================================================
  71. C REMPLISSAGE DE TAB1(T_ELIP) ET TAB2(T_DELIP) =
  72. C================================================
  73.  
  74.  
  75. CALL ELPTI7 (NMAX,NM,ENTIER)
  76. STAB=ENTIER
  77. SEGACT STAB
  78. TAB1(1)=0.
  79. TAB2(1)=0.
  80. DO I=1,NE
  81. A=INTELL(I,2)
  82. AV=0.5*(REAL(I)-1.)/NE
  83. TAB1(I)=A+(0.707107*(LOG(1.-(4*AV*AV))))-(0.3127313*AV*AV)
  84. IF (I.GE.3) THEN
  85. TAB2(I-1)=(TAB1(I)-TAB1(I-2))*NE
  86. END IF
  87. END DO
  88. TAB1(NE+1)=(3*(TAB1(NE)-TAB1(NE-1)))+TAB1(NE-2)
  89. TAB2(NE)=(TAB1(NE+1)-TAB1(NE-1))*NE
  90. TAB2(NE+1)=(2*TAB2(NE))-TAB2(NE-1)
  91. SEGDES STAB
  92.  
  93. C============================
  94. C ON BOUCLE SUR LES NOEUDS =
  95. C============================
  96. SEGACT MCHPO1
  97. DO 2 IPT=1,NNNOE
  98. L=IPT1.NUM(1,IPT)
  99. IREF= (IDIM+1)*L
  100. XM=XCOOR (IREF-IDIM)
  101. YM=XCOOR (IREF-IDIM+1)
  102. ZM=XCOOR (IREF-IDIM+2)
  103. RM=((XM**2)+(YM**2))**0.5
  104. C write(6,*) 'RM=',RM
  105. if ( xm.eq.0 ) then
  106. if ( ym.gt.0 ) then
  107. theta = xpi/2.
  108. else
  109. if ( ym.lt.0 ) then
  110. theta = -1.*xpi/2.
  111. else
  112. theta = 1.
  113. end if
  114. end if
  115. else
  116. THETA= ATAN(YM/XM)
  117. end if
  118.  
  119. C LECTURE DU CHAMP POINT
  120. BX=0.
  121. BY=0.
  122. BZ1=0.
  123. FLU=0.
  124. DO 3 I=1,MCHPO1.IPCHP(/1)
  125. MSOUPO=MCHPO1.IPCHP(I)
  126. SEGACT MSOUPO
  127. IPT3=IGEOC
  128. SEGACT IPT3
  129. MPOVAL=IPOVAL
  130. SEGACT MPOVAL
  131. c write (6,*) 'nbr compo =' ,nocomp(/2)
  132.  
  133. DO 4 K=1,IPT3.NUM(/2)
  134. L1=IPT3.NUM(1,K)
  135. IREF1=(IDIM+1)*L1
  136. X=XCOOR (IREF1-IDIM)
  137. Y=XCOOR (IREF1-IDIM+1)
  138. Z=XCOOR (IREF1-IDIM+2)
  139. if (nocomp(/2).eq.0) then
  140. H = 1.e-5
  141. COUR = 1.
  142. end if
  143. if (nocomp(/2).eq.1) then
  144. if (nocomp(1).eq.'E ') then
  145. H = vpocha(k,1)
  146. COUR = 1.
  147. else
  148. if (nocomp(1).eq.'I ') then
  149. H = 1.e-5
  150. COUR = vpocha(k,1)
  151. else
  152. call erreur (961)
  153. end if
  154. end if
  155. end if
  156. if ( nocomp(/2).eq.2) then
  157. if ((nocomp(1).eq.'E ').and.(nocomp(2).eq.'I ')) then
  158. H=VPOCHA(K,1)
  159. COUR=VPOCHA(K,2)
  160. else
  161. if ((nocomp(1).eq.'I ').and.(nocomp(2).eq.'E ')) then
  162. H=VPOCHA(K,2)
  163. COUR=VPOCHA(K,1)
  164. else
  165. call erreur (961)
  166. end if
  167. end if
  168. end if
  169. R=((X**2)+(Y**2))**0.5
  170. FLU=FLU + (COUR*(FLUXBC(RM,ZM,R,Z,H,NE,TAB1)/1.E+6))
  171. CALL CHAMPM(RM,ZM,R,Z,H,NE,TAB1,TAB2,BR,BZ)
  172. IF (XM.LT.0) THEN
  173. BX=BX- ( COUR*(BR/1.E+6)*COS (THETA))
  174. BY=BY- ( COUR*(BR/1.E+6)*SIN (THETA))
  175. BZ1=BZ1 + (COUR*(BZ/1.E+6))
  176. ELSE
  177. BX=BX+ ( COUR*(BR/1.E+6)*COS (THETA))
  178. BY=BY+ ( COUR*(BR/1.E+6)*SIN (THETA))
  179. BZ1= BZ1 + ( COUR*(BZ/1.E+6))
  180. END IF
  181. 4 CONTINUE
  182. SEGDES MPOVAL
  183. SEGDES IPT3
  184. SEGDES MSOUPO
  185. 3 CONTINUE
  186. C WRITE(6,*) 'FLU=',FLU
  187. C WRITE(6,*) 'BX= ',BX,';BY= ',BY,';BZ= ',BZ1
  188. IGEO(IPT)=L
  189. BB(1,IPT)=BX
  190. IBIN(1,IPT)=1
  191. BB(2,IPT)=BY
  192. IBIN(2,IPT)=1
  193. BB(3,IPT)=BZ1
  194. IBIN(3,IPT)=1
  195. BB(4,IPT)=FLU
  196. IBIN(4,IPT)=1
  197. 2 CONTINUE
  198. SEGDES IPT1
  199.  
  200. CALL CRECHP(MTRAV,MCHPO3)
  201. ENT=MCHPO3
  202. SEGSUP MTRAV
  203. C WRITE(6,*) 'COUCOU1',ENT
  204. RETURN
  205. END
  206.  
  207.  
  208.  
  209.  
  210.  

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