Télécharger biokam.eso

Retour à la liste

Numérotation des lignes :

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

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