Télécharger dfer.eso

Retour à la liste

Numérotation des lignes :

  1. C DFER SOURCE BP208322 16/11/18 21:16:26 9177
  2. SUBROUTINE DFER
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. -INC SMELEME
  6. -INC CCGEOME
  7. -INC CCOPTIO
  8. -INC SMCOORD
  9. -INC TMTRAV
  10. -INC SMCHPOI
  11.  
  12. SEGMENT PAQUET
  13. INTEGER LIGNE(NELEM)
  14. ENDSEGMENT
  15. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  16. SEGMENT IDCP(ITE)
  17.  
  18. c write(6,*)'ok'
  19. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  20. IF (IERR.NE.0) RETURN
  21. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  22. IF (IERR.NE.0) RETURN
  23. CALL LIRREE(XVAL,0,iretou)
  24. Zi=0.3
  25. if(iretou.ne.0) ZI=xval
  26. C
  27. C IPT1 MAILLAGE BETON
  28. C IPT2 MAILLAGE FER
  29. C
  30. C Création des lignes
  31. II=IPT2
  32. JJ=0
  33. * write(6,*) ' appel a paqlis'
  34. CALL PAQLIG(II,KK)
  35. * write(6,*) ' ierr ' ,ierr
  36. if(ierr.ne.0) return
  37. PAQUET=KK
  38. segact paquet
  39. * write(6,4732) ( ligne (io),io=1,ligne(/1))
  40. 4732 format (10i7)
  41. * write(6,*) ' retpur de paqlis'
  42. C
  43. C
  44. ITE=0
  45. SEGACT IPT1
  46. IPT3=IPT1
  47. SEGINI ICPR
  48. DO 1 I=1,MAX(1,IPT1.LISOUS(/1))
  49. IF (IPT1.LISOUS(/1).NE.0) THEN
  50. IPT3=IPT1.LISOUS(I)
  51. SEGACT IPT3
  52. ENDIF
  53. DO 4 L=1,IPT3.NUM(/2)
  54. DO 3 JJ=1,IPT3.num(/1)
  55. IPOIT=IPT3.NUM(JJ,L)
  56. IF (ICPR(IPOIT).NE.0) GOTO 3
  57. ITE=ITE+1
  58. ICPR(IPOIT)=ITE
  59. 3 CONTINUE
  60. 4 CONTINUE
  61. IF (IPT1.LISOUS(/1).NE.0) SEGDES IPT3
  62. 1 CONTINUE
  63. SEGDES IPT1
  64. NBNN=1
  65. NBELEM=ITE
  66. NBSOUS=0
  67. NBREF=0
  68. SEGINI MELEME
  69. ITYPEL=1
  70. ia=1
  71. DO I=1,ICPR(/1)
  72. IF (ICPR(I).NE.0) then
  73. NUM(1,ia)=I
  74. ia=ia+1
  75. endif
  76. END DO
  77. SEGSUP ICPR
  78. SEGACT PAQUET
  79. NC=1
  80. SEGINI MSOUPO
  81. IGEOC=MELEME
  82. N=NBELEM
  83. SEGINI MPOVAL
  84. DO 6 I=1,NUM(/2)
  85. CHB=0.
  86. J=0
  87. IREF=num(1,i)*(IDIM+1)-IDIM
  88. XP=XCOOR(IREF)
  89. YP=XCOOR(IREF+1)
  90. ZP=XCOOR(IREF+2)
  91. IF (IDIM.EQ.2) THEN
  92. ZP=0.
  93. END IF
  94. c write(*,*)'xp',xp,'yp',yp,'zp',zp
  95. DO WHILE (J.NE.LIGNE(/1))
  96. J=J+1
  97. DIST=10E15
  98. na=LIGNE(J)
  99. IREFA=NA*(IDIM+1)-IDIM
  100. XA=XCOOR(IREFA)
  101. YA=XCOOR(IREFA+1)
  102. ZA=XCOOR(IREFA+2)
  103. IF (IDIM.EQ.2) THEN
  104. ZA=0.
  105. END IF
  106. j=j+1
  107. if(i.eq.1) then
  108. * write(6,*) ' point de depart ' , na
  109. endif
  110. DO WHILE (LIGNE(J).NE.0)
  111. c write(6,*)ligne(j)
  112. nb=LIGNE(J)
  113. if(i.eq.1) then
  114. * write(6,*) nb
  115. endif
  116. IREFB=NB*(IDIM+1)-IDIM
  117. XB=XCOOR(IREFB)
  118. YB=XCOOR(IREFB+1)
  119. ZB=XCOOR(IREFB+2)
  120. IF (IDIM.EQ.2) THEN
  121. ZB=0.
  122. END IF
  123.  
  124. CALL DISTAN(XP,XA,XB,YP,YA,YB,ZP,ZA,ZB,
  125. $ DISTINT,MARQ)
  126. c if (marq.eq.0) then
  127. c write(*,*)'xa',xa,'ya',ya,'za',za
  128. c write(*,*)'xb',xb,'yb',yb,'zb',zb
  129. c end if
  130. IF (MARQ.NE.0) THEN
  131. xl1=((XB-XP)**2+(YB-YP)**2+(ZB-ZP)**2)**0.5
  132. xl2=((XA-XP)**2+(YA-YP)**2+(ZA-ZP)**2)**0.5
  133. DISTINT=MIN(xl1,xl2)
  134. ENDIF
  135. IF (DISTINT.LE.DIST) THEN
  136. DIST=DISTINT
  137. ENDIF
  138. J=J+1
  139. xa=xb
  140. ya=yb
  141. za=zb
  142. END DO
  143. CHB=CHB+XINFLU(DIST,ZI)
  144. c write(6,*)'dist',dist,'influen',XINFLU(DIST,ZI)
  145. c write(6,*)'idcp',idcp(i),'chp',chb
  146. c if (XINFLU(DIST,ZI).ne.0) then
  147. c write(*,*)'xp',xp,'yp',yp,'zp',zp
  148. c write(*,*)'xa',xa,'ya',ya,'za',za
  149. c write(*,*)'xb',xb,'yb',yb,'zb',zb
  150. c write(6,*)jjelem,'chp',chb
  151. c write(6,*)'dist',dist,'influen',XINFLU(DIST,ZI)
  152. c endif
  153. END DO
  154. VPOCHA(I,1)=CHB
  155.  
  156. 6 CONTINUE
  157. IPOVAL=MPOVAL
  158. NOCOMP(1)='DFER'
  159. SEGDES MPOVAL
  160. NSOUPO=1
  161. NAT=1
  162. SEGINI MCHPOI
  163. JATTRI(1)=2
  164. IPCHP(1)=MSOUPO
  165. MOCHDE='MANUEL'
  166. SEGDES MSOUPO,meleme
  167. SEGDES IPT2,IPT1
  168. CALL ECROBJ('CHPOINT ',MCHPOI)
  169. RETURN
  170. END
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  

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