Télécharger normno.eso

Retour à la liste

Numérotation des lignes :

  1. C NORMNO SOURCE BP208322 16/11/18 21:19:34 9177
  2. SUBROUTINE NORMNO(MELEME,MELEMS,MCHPOI,IRET)
  3. C************************************************************************
  4. C
  5. C
  6. C
  7. C************************************************************************
  8. IMPLICIT INTEGER(I-N)
  9. IMPLICIT REAL*8 (A-H,O-Z)
  10. C
  11. -INC SMELEME
  12. POINTEUR MELEMS.MELEME
  13. -INC SMLENTI
  14. -INC SMLREEL
  15. -INC SMCOORD
  16. -INC SIZFFB
  17. -INC SMCHPOI
  18. -INC CCGEOME
  19. -INC CCOPTIO
  20. -INC CCREEL
  21. C
  22. CHARACTER*8 NOM0
  23. C***
  24. C
  25. IRET=0
  26.  
  27. IAXI=0
  28. IF(IFOMOD.EQ.0)IAXI=2
  29. DEUPI=1.D0
  30. IF(IAXI.NE.0)DEUPI=2.D0*XPI
  31.  
  32. SEGACT MELEMS
  33. NAT=2
  34. NSOUPO=1
  35. SEGINI MCHPOI
  36. NC=IDIM
  37. SEGINI MSOUPO
  38. IPCHP(1)=MSOUPO
  39. C write(6,*)' MSOUPO=',MSOUPO,'MCHPOI=',MCHPOI
  40. C nature indeterminee (2 discret)
  41. JATTRI(1)=0
  42. NOCOMP(1)='UX'
  43. NOCOMP(2)='UY'
  44. IF(IDIM.EQ.3)NOCOMP(3)='UZ'
  45. IGEOC=MELEMS
  46. C write(6,*)' MELEMS=',MELEMS
  47. N=MELEMS.NUM(/2)
  48. SEGINI MPOVAL
  49. IPOVAL=MPOVAL
  50. JG=N
  51. SEGINI MLREEL
  52.  
  53. CALL KRIPAD(MELEMS,MLENTI)
  54. SEGDES MELEMS
  55. SEGACT MELEME
  56.  
  57. DO 1 L=1,MAX(1,LISOUS(/1))
  58. IPT1=MELEME
  59. IF(LISOUS(/1).NE.0)IPT1=LISOUS(L)
  60. SEGACT IPT1
  61. NOM0=NOMS(IPT1.ITYPEL)//' '
  62. C write(6,*)' NOM0 ,IDIM',NOM0,IDIM
  63. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  64. SEGACT IZFFM*MOD
  65. IZHR=KZHR(1)
  66. SEGACT IZHR*MOD
  67. NES=GR(/1)
  68. NPG=GR(/3)
  69. NBNN =IPT1.NUM(/1)
  70. NBELEM=IPT1.NUM(/2)
  71.  
  72. DO 2 K=1,NBELEM
  73.  
  74. DO 20 I=1,NBNN
  75. J=IPT1.NUM(I,K)
  76. DO 10 N=1,IDIM
  77. XYZ(N,I) = XCOOR((J-1)*(IDIM+1)+N)
  78. 10 CONTINUE
  79. 20 CONTINUE
  80.  
  81. CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,
  82. & NES,IDIM,NBNN,NPG,IAXI,AIRE,AJ,SGN)
  83.  
  84. DO 22 I=1,NBNN
  85. AX=0.D0
  86. AY=0.D0
  87. AZ=0.D0
  88.  
  89. DO 17 LG=1,NPG
  90. AX=AX+FN(I,LG)*AJ(1,IDIM,LG)*PGSQ(LG)*DEUPI*RPG(LG)
  91. AY=AY+FN(I,LG)*AJ(2,IDIM,LG)*PGSQ(LG)*DEUPI*RPG(LG)
  92. IF(IDIM.EQ.3)THEN
  93. AZ=AZ+FN(I,LG)*AJ(3,IDIM,LG)*PGSQ(LG)*DEUPI*RPG(LG)
  94. ENDIF
  95. 17 CONTINUE
  96.  
  97. IU=LECT(IPT1.NUM(I,K))
  98. VPOCHA(IU,1)=VPOCHA(IU,1)+AX
  99. VPOCHA(IU,2)=VPOCHA(IU,2)+AY
  100. IF(IDIM.EQ.3)THEN
  101. VPOCHA(IU,3)=VPOCHA(IU,3)+AZ
  102. ENDIF
  103. 22 CONTINUE
  104.  
  105. 2 CONTINUE
  106. SEGDES IPT1
  107. SEGSUP IZFFM,IZHR
  108. 1 CONTINUE
  109. SEGDES MELEME
  110. N=VPOCHA(/1)
  111.  
  112. IF(IDIM.EQ.2)THEN
  113. DO 31 I=1,N
  114. AN=(VPOCHA(I,1)*VPOCHA(I,1) + VPOCHA(I,2)*VPOCHA(I,2))**0.5D0
  115. if (abs(an).lt.xpetit) an=1.d0
  116. VPOCHA(I,1)=VPOCHA(I,1)/AN
  117. VPOCHA(I,2)=VPOCHA(I,2)/AN
  118. C write(6,*)' ux uy ',VPOCHA(I,1),VPOCHA(I,2)
  119. 31 CONTINUE
  120.  
  121. ELSE
  122. DO 33 I=1,N
  123. AN=(VPOCHA(I,1)*VPOCHA(I,1) + VPOCHA(I,2)*VPOCHA(I,2)
  124. & + VPOCHA(I,3)*VPOCHA(I,3) )**0.5D0
  125. if (abs(an).lt.xpetit) an=1.d0
  126. VPOCHA(I,1)=VPOCHA(I,1)/AN
  127. VPOCHA(I,2)=VPOCHA(I,2)/AN
  128. VPOCHA(I,3)=VPOCHA(I,3)/AN
  129. 33 CONTINUE
  130. ENDIF
  131.  
  132. SEGDES MCHPOI,MSOUPO,MPOVAL
  133. SEGSUP MLENTI,MLREEL
  134. IRET=1
  135.  
  136. RETURN
  137. 1002 FORMAT(10(1X,1PE11.4))
  138. 1001 FORMAT(20(1X,I5))
  139. END
  140.  
  141.  
  142.  
  143.  
  144.  
  145.  
  146.  
  147.  
  148.  
  149.  
  150.  

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