Télécharger ksof.eso

Retour à la liste

Numérotation des lignes :

  1. C KSOF SOURCE CHAT 05/01/13 01:08:43 5004
  2. SUBROUTINE KSOF
  3. C*************************************************************************
  4. C
  5. C Objet : Change un champoint VECT SOMMET en SCAL FACE
  6. C Syntaxe : VFACE = KSOF VSOMMET TABDOM ;
  7. C
  8. C*************************************************************************
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8 (A-H,O-Z)
  11.  
  12. -INC CCOPTIO
  13. -INC SMCOORD
  14. -INC SMLENTI
  15. POINTEUR LEF.MLENTI
  16. -INC SMTABLE
  17. POINTEUR MTABD.MTABLE
  18. -INC SMCHPOI
  19. POINTEUR MCHPF.MCHPOI,MCHPN.MCHPOI,MPOVF.MPOVAL,MPOVN.MPOVAL
  20. -INC SMELEME
  21. POINTEUR MELEMF.MELEME,MELEMP.MELEME
  22.  
  23. PARAMETER (NTB=1)
  24. CHARACTER*8 LTAB(NTB),TYPE,TYPC
  25. DIMENSION KTAB(NTB)
  26. DATA LTAB/'DOMAINE '/
  27. C***
  28. IAXI=0
  29. IF(IFOMOD.EQ.0)IAXI=2
  30.  
  31. NTO=NTB
  32. CALL LITABS(LTAB,KTAB,NTB,NTO,IRET)
  33. IF(IRET.EQ.0)RETURN
  34. MTABD=KTAB(1)
  35. SEGACT MTABD
  36.  
  37. CALL LIROBJ('CHPOINT ',MCHPOI,1,IRET)
  38. IF(IRET.EQ.0)THEN
  39. WRITE(6,*)' On attend un CHPOINT'
  40. RETURN
  41. ENDIF
  42. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOS)
  43. IF(TYPC.NE.'SOMMET')THEN
  44. WRITE(6,*)'On attend un CHAMPOINT SOMMET'
  45. SEGDES MCHPOI,MPOVAL
  46. RETURN
  47. ENDIF
  48. NC=VPOCHA(/2)
  49. IF(NC.NE.IDIM)THEN
  50. WRITE(6,*)'On attend un CHAMPOINT VECT SOMMET'
  51. SEGDES MCHPOI,MPOVAL
  52. RETURN
  53. ENDIF
  54. CALL KRIPAD(IGEOS,MLENTI)
  55.  
  56. CALL LEKTAB(MTABD,'FACE',MELEMF)
  57. IF(MELEMF.EQ.0)GO TO 90
  58. C? CALL KRIPAD(MELEMF,MLENT1)
  59. SEGACT MELEMF
  60. NBF=MELEMF.NUM(/2)
  61. CALL RSETXI(LECT,MELEMF.NUM,NBF)
  62.  
  63. CALL LEKTAB(MTABD,'FACEP',MELEMP)
  64. IF(MELEMP.EQ.0)GO TO 90
  65. CALL LEKTAB(MTABD,'XXNORMAF',MCHPN)
  66. IF(MCHPN.EQ.0)GO TO 90
  67. C CALL KRIPAD(MELEMP,MLENTI)
  68.  
  69. CALL LICHT(MCHPN,MPOVN,TYPE,IGEOM)
  70. TYPE='FACE'
  71. NC=1
  72. CALL CRCHPT(TYPE,MELEMF,NC,MCHPF)
  73. CALL LICHT(MCHPF,MPOVF,TYPE,IGEOM)
  74.  
  75.  
  76. SEGACT MELEMP
  77. NBSOUS=MELEMP.LISOUS(/1)
  78. IF(NBSOUS.EQ.0)NBSOUS=1
  79. NF=0
  80. DO 1 KS=1,NBSOUS
  81. IPT1=MELEMP
  82. IF(NBSOUS.NE.1)IPT1=MELEMP.LISOUS(KS)
  83. SEGACT IPT1
  84. NS=IPT1.NUM(/1)-1
  85. NEL=IPT1.NUM(/2)
  86.  
  87. IF(IAXI.EQ.0)THEN
  88. DO 2 K=1,NEL
  89. C? NF=NF+1
  90. C? NF=MLENT1.LECT(IPT1.NUM(NS+1,K))
  91. NF= LECT(IPT1.NUM(NS+1,K))
  92. C write(6,*)' 0 NF=',nf
  93. C NF=IPT1.NUM(2,K)
  94. C NF=IPADL(NF)
  95. VI=0.D0
  96. DO 22 IS=1,NS
  97. N1=IPT1.NUM(IS,K)
  98. N1=LECT(N1)
  99. DO 21 I=1,IDIM
  100. VI=VI+VPOCHA(N1,I)*MPOVN.VPOCHA(NF,I)
  101. 21 CONTINUE
  102. 22 CONTINUE
  103. C write(6,*)' NF=',nf
  104. C write(6,*)'Normale : ',MPOVN.VPOCHA(NF,1),MPOVN.VPOCHA(NF,2)
  105. MPOVF.VPOCHA(NF,1)=VI/FLOAT(NS)
  106. C write(6,*)'VI/F=',MPOVF.VPOCHA(NF,1)
  107. 2 CONTINUE
  108.  
  109. ELSEIF(IAXI.EQ.2)THEN
  110. f23=2.D0/3.D0
  111. DO 3 K=1,NEL
  112. C? NF=NF+1
  113. C? NF=MLENT1.LECT(IPT1.NUM(NS+1,K))
  114. NF= LECT(IPT1.NUM(NS+1,K))
  115. C write(6,*)' 2 NF=',nf
  116. N1=IPT1.NUM(1,K)
  117. R1=XCOOR((N1-1)*3+1)
  118. N1=LECT(N1)
  119. N2=IPT1.NUM(2,K)
  120. R2=XCOOR((N2-1)*3+1)
  121. N2=LECT(N2)
  122. VX1=VPOCHA(N1,1)
  123. VX2=VPOCHA(N2,1)
  124. VY1=VPOCHA(N1,2)
  125. VY2=VPOCHA(N2,2)
  126. DN = ABS(MPOVN.VPOCHA(NF,2))
  127. IF(DN.GT.1.D-6)THEN
  128. VN1=VX1*MPOVN.VPOCHA(NF,1)+VY1*MPOVN.VPOCHA(NF,2)
  129. VN2=VX2*MPOVN.VPOCHA(NF,1)+VY2*MPOVN.VPOCHA(NF,2)
  130. DR=R2-R1
  131. VN=VN1*R2-VN2*R1+F23*(VN2-VN1)/DR*(R2**3-R1**3)/(R2+R1)
  132. MPOVF.VPOCHA(NF,1)=VN/DR
  133. ELSE
  134. C calcul simplifier pour les faces casi verticale (sinon X/0.)
  135. VX=(VX1+VX2)*0.5D0
  136. VY=(VY1+VY2)*0.5D0
  137. MPOVF.VPOCHA(NF,1)=VX*MPOVN.VPOCHA(NF,1)+VY*MPOVN.VPOCHA(NF,2)
  138. ENDIF
  139. 3 CONTINUE
  140. ENDIF
  141.  
  142. SEGDES IPT1
  143. 1 CONTINUE
  144. SEGDES MELEMP,MELEMF
  145.  
  146. SEGSUP MLENTI
  147. CALL ECROBJ('CHPOINT ',MCHPF)
  148. SEGDES MCHPF,MPOVF,MTABD
  149. SEGDES MCHPOI,MPOVAL
  150. SEGDES MCHPN,MPOVN
  151.  
  152. RETURN
  153.  
  154. 90 CONTINUE
  155. WRITE(6,*)' Retour anormal de KSOF'
  156. RETURN
  157.  
  158. END
  159.  
  160.  
  161.  
  162.  

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