Télécharger carwrk.eso

Retour à la liste

Numérotation des lignes :

  1. C CARWRK SOURCE CB215821 17/07/21 21:15:01 9513
  2. SUBROUTINE CARWRK(XF,YF,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE,
  3. $ XORG,YORG,NPN,EDICON,ICOO,ITRAVA)
  4. C
  5. C EVALUATE POTENTIAL AND ITS FIRST AND SECOND DERIVATIVES
  6. C-----------------------------------------------------------------------
  7. C
  8. IMPLICIT INTEGER(I-N)
  9. IMPLICIT REAL*8(A-H,O-Z)
  10. C-----------------------------------------------------------------------
  11. C
  12. COMPLEX*16 Z, ZE, ZN, ZP, ZPP
  13. C
  14. C-----------------------------------------------------------------------
  15. SEGMENT EDICON
  16. INTEGER KSTRT, KSTEP, NMIR, IS
  17. REAL*8 CROT, SROT, SYMFCT
  18. LOGICAL LREAL, LIMAG
  19. ENDSEGMENT
  20. SEGMENT ICOO
  21. REAL*8 X(MV),Y(MV),P(MV),WNODE(MV)
  22. INTEGER LISVO(MV)
  23. ENDSEGMENT
  24. SEGMENT ITRAVA
  25. REAL*8 KENN(M42,2),SIGMA(M42),DELRHO(M42),C(M50,M50)
  26. REAL*8 AK(M50),UM(M50),RM(M50)
  27. INTEGER IL(M50)
  28. ENDSEGMENT
  29. C
  30. C COMMON // NEU, NPN, NPU
  31. C
  32. C TABLES AND WORKING STORE FOR POTENTIAL AND FIELD EDIT
  33. C
  34. C
  35. C SET UP EQUATIONS FOR LEAST-SQUARES FIT
  36. C
  37. M50=RM(/1)
  38. NPU = NPN
  39. NTERM =MIN(( NPU - 4),15)
  40. IF(LREAL .AND. LIMAG) NTERM = MIN( ((NPU - 5) / 2 ),7)
  41. KEND = KSTRT + NTERM * KSTEP
  42. XE = XF - XORG
  43. YE = YF - YORG
  44. ZE = CMPLX(XE,YE)
  45. IFLAG = 0
  46. J = 0
  47. C
  48. DO 90 JJ = 1, NPN
  49. C
  50. IF(WNODE(JJ) .EQ. 0.0) GO TO 90
  51. XN = X(JJ) - XORG
  52. YN = Y(JJ) - YORG
  53. ZN = CMPLX(XN,YN)
  54. U = P(JJ)
  55. C
  56. C LOGARITHMIC TERMS DUE TO FILAMENTS
  57. C TERMS DUE TO OTHER SOURCES
  58. C
  59. C
  60. C COEFFICIENT MATRIX
  61. C
  62. J = J + 1
  63. C(J,1) = WNODE(JJ)
  64. I = 1
  65. C
  66. IF(KEND .LT. KSTRT) GO TO 80
  67. C
  68. DO 70 KI = KSTRT, KEND, KSTEP
  69. Z = ZN**KI
  70. C
  71. IF(.NOT. LREAL) GO TO 60
  72. I = I + 1
  73. C(J,I) = WNODE(JJ) * REAL(Z)
  74. C
  75. 60 IF(.NOT. LIMAG) GO TO 70
  76. I = I + 1
  77. C(J,I) = WNODE(JJ) * AIMAG(Z)
  78. C
  79. 70 CONTINUE
  80. C
  81. 80 C(J,I+1) = WNODE(JJ) * U
  82. C
  83. 90 CONTINUE
  84. C
  85. C-----------------------------------------------------------------------
  86. C PERFORM THE 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 PERFORM THE ANALYTIC DIFFERENTIATION
  92. C
  93. IFLAG = KFLAG
  94. U = AK(1)
  95. UX = 0.0
  96. UY = 0.0
  97. UXX = 0.0
  98. UXY = 0.0
  99. UYY = 0.0
  100. C
  101. C HARMONIC TERMS
  102. C
  103. IF(KEND .LT. KSTRT) GO TO 150
  104. I = 1
  105. C
  106. DO 140 KI = KSTRT, KEND, KSTEP
  107. Z = ZE**KI
  108. ZP = (1.0,0.0)
  109. IF(KI .GT. 1) ZP = FLOAT(KI) * ZE ** (KI-1)
  110. ZPP = (0.0,0.0)
  111. IF(KI .EQ. 2) ZPP = (2.0,0.0)
  112. IF(KI .GT. 2) ZPP = FLOAT(KI*(KI-1)) * ZE ** (KI-2)
  113. C
  114. IF(.NOT. LREAL) GO TO 120
  115. I = I + 1
  116. U = U + AK(I) * REAL(Z)
  117. UX = UX + AK(I) * REAL(ZP)
  118. UY = UY - AK(I) * AIMAG(ZP)
  119. UXX = UXX + AK(I) * REAL(ZPP)
  120. UXY = UXY - AK(I) * AIMAG(ZPP)
  121. C
  122. 120 IF(.NOT. LIMAG) GO TO 140
  123. I = I + 1
  124. U = U + AK(I) * AIMAG(Z)
  125. UX = UX + AK(I) * AIMAG(ZP)
  126. UY = UY + AK(I) * REAL(ZP)
  127. UXX = UXX + AK(I) * AIMAG(ZPP)
  128. UXY = UXY + AK(I) * REAL(ZPP)
  129. C
  130. 140 CONTINUE
  131. C
  132. 150 UYY = - UXX
  133. C
  134. C
  135. C TERMS DUE TO OTHER SOURCES
  136. C
  137. 200 KFLAG = IFLAG
  138. RETURN
  139. C***********************************************************************
  140. END
  141.  
  142.  
  143.  
  144.  
  145.  

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