Télécharger cylwrk.eso

Retour à la liste

Numérotation des lignes :

cylwrk
  1. C CYLWRK SOURCE GF238795 18/02/01 21:15:05 9724
  2. SUBROUTINE CYLWRK(RF,ZF,KFLAG,U,UR,UZ,URR,URZ,UZZ,ITYPE,
  3. $NPN,EDICON,ICOO,ITRAVA)
  4. C
  5. C EVALUATE POTENTIAL AND ITS DERIVATIVES FOR CYLINDER COORDINATES
  6. C-----------------------------------------------------------------------
  7. C
  8. IMPLICIT INTEGER(I-N)
  9. IMPLICIT REAL*8(A-H,O-Z)
  10. C POTENTIAL VALUES
  11. SEGMENT EDICON
  12. INTEGER KSTRT, KSTEP, NMIR, IS
  13. REAL*8 CROT, SROT, SYMFCT
  14. LOGICAL LREAL, LIMAG
  15. ENDSEGMENT
  16. SEGMENT ICOO
  17. REAL*8 X(MV),Y(MV),P(MV),WNODE(MV)
  18. INTEGER LISVO(MV)
  19. ENDSEGMENT
  20. SEGMENT ITRAVA
  21. REAL*8 KENN(M42,2),SIGMA(M42),DELRHO(M42),C(M50,M50)
  22. REAL*8 AK(M50),UM(M50),RM(M50)
  23. INTEGER IL(M50)
  24. ENDSEGMENT
  25. C COMMON // NEU, NPN, NPU
  26. C
  27. C CONSTANTS DESCRIBING SYMMETRY CONDITIONS
  28. C
  29. C
  30. C SOURCE TERMS
  31. C
  32. C TABLES AND WORKING STORE FOR POTENTIAL AND FIELD EDIT
  33. C
  34. C-----------------------------------------------------------------------
  35. C
  36. M50=RM(/1)
  37. NPU = MIN(NPN,19)
  38. KEND = KSTRT + KSTEP * (NPU - IS - 2)
  39. IFLAG = 0
  40. J = 0
  41. C
  42. DO 90 JJ = 1, NPN
  43. C
  44. IF(WNODE(JJ) .EQ. 0.0) GO TO 90
  45. RN = X(JJ)
  46. ZN = Y(JJ)
  47. UN = P(JJ)
  48. C
  49. C SET UP HARMONIC FUNCTIONS FOR LOCATION (RN,ZN)
  50. C NOTE. U(SUBSCRIPT M) IS STORED IN UM(M+3)
  51. C R(SUBSCRIPT M) IS STORED IN RM(M+3)
  52. C THE DO LOOP INDEX K IS (M+1)
  53. C
  54. UM(3) = 1.0
  55. IF(IS .NE. 0) UM(3) = RN
  56. RM(3) = FLOAT(IS+IS) * ZN
  57. C
  58. DO 40 K = 2, KEND
  59. UM(K+2) = (RN*RM(K+1) + ZN*UM(K+1))
  60. RM(K+2) = (ZN*RM(K+1) - RN*UM(K+1)) * FLOAT(K+IS+IS-1) / FLOAT(K)
  61. 40 CONTINUE
  62. C
  63. C SET UP COEFFICIENT MATRIX FOR FIT
  64. C
  65. J = J + 1
  66. I = IS
  67. C(J,1) = WNODE(JJ)
  68. C
  69. IF(KEND .LT. KSTRT) GO TO 80
  70. C
  71. DO 70 I = IS+1, IS+1+(KEND-KSTRT)/KSTEP
  72. K = KSTRT + (I-IS-1)*KSTEP
  73. c DO 70 K = KSTRT, KEND, KSTEP
  74. c I = I + 1
  75. C(J,I) = WNODE(JJ) * UM(3) * UM(K+2)
  76. 70 CONTINUE
  77. C
  78. 80 C(J,I+1) = WNODE(JJ) * UN
  79. C
  80. 90 CONTINUE
  81. C WRITE(6,FMT= ' ('' I ET J MAX '',/,(2I6))') I,J
  82. C WRITE(6,FMT= ' ('' KSTRT KSTEP KEND ITYPE '',/,(4I5))') KSTRT,
  83. C $KSTEP,KEND,ITYPE
  84. C
  85. C-----------------------------------------------------------------------
  86. C PERFORM LEAST-SQUARES FIT
  87. C
  88. CALL GLSQ(C,AK,IL,J,I,ALFA,1.0D-10,1.0D-10,M50)
  89. C
  90. C-----------------------------------------------------------------------
  91. C COMPUTE POTENTIAL AND DERIVATIVES
  92. C
  93. UM(1) = 0.0
  94. UM(2) = 0.0
  95. UM(3) = 1.0
  96. IF(IS .NE. 0) UM(3) = RF
  97. RM(1) = 0.0
  98. RM(2) = FLOAT(IS)
  99. RM(3) = 2.0 * RM(2) * ZF
  100. C
  101. DO 110 K = 2, KEND
  102. UM(K+2) = (RF*RM(K+1) + ZF*UM(K+1))
  103. RM(K+2) = (ZF*RM(K+1) - RF*UM(K+1)) * FLOAT(K+IS+IS-1) / FLOAT(K)
  104. 110 CONTINUE
  105. C
  106. IFLAG = KFLAG
  107. U = AK(1) * FLOAT(IS)
  108. UR = 0.0
  109. UZ = 0.0
  110. URZ = 0.0
  111. UZZ = 0.0
  112. I = IS
  113. C
  114. IF(KEND .LT. KSTRT) GO TO 150
  115. C
  116. DO 120 K = KSTRT, KEND, KSTEP
  117. I = I + 1
  118. U = U + AK(I) * UM(3) * UM(K+2)
  119. XK = AK(I) * FLOAT(K+IS+IS-1)
  120. UR = UR + XK * RM(K+1)
  121. UZ = UZ + XK * UM(K+1)
  122. XK = XK * FLOAT(K+IS+IS-2)
  123. URZ = URZ + XK * RM(K)
  124. UZZ = UZZ + XK * UM(K)
  125. 120 CONTINUE
  126. C
  127. 150 KFLAG = IFLAG
  128. URR = - UZZ
  129. RETURN
  130. C***********************************************************************
  131. END
  132.  
  133.  
  134.  
  135.  

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