ADAS Subroutine dipsum
C REAL FUNCTION DIPSUM*8(JZ,L,E1,E2) IMPLICIT REAL*8(A-H,O-Z) C C PURPOSE: Calculates a Burgess Dipole Sum. C C CALCULATES THE SUM GIVEN IN EQUATIONS (10) AND (11) OF A. BURGESS, C J. PHYS. B7,?,1974. SET JZ TO ZERO FOR THE ZERO CHARGE (NEUTRAL C ATOM) CASE. SET L TO THE LOWER LIMIT OF SUMMATION (MUST BE GREATER C THAN ZERO). SET E1=(KAPPA1)**2 FOR NON ZERO CHARGE, =(K1)**2 C FOR ZERO CHARGE. SET E2=(KAPPA2)**2 FOR NON ZERO CHARGE, C =(K2)**2 FOR ZERO CHARGE. C----------------------------------------------------------------------- C C VERSION : 1.1 C DATE : ? C MODIFIED : H P Summers C - Initial version. C C VERSION : 1.2 C DATE : 16-05-2007 C MODIFIED : Allan Whiteford C - Remove listing information from colums 72+. C - Updated comments as part of subroutine documentation C procedure. C----------------------------------------------------------------------- L1=L L2=L-1 IF(JZ)1,2,1 1 F1=R8FDIP(E1,L1,E2,L2) F2=R8FDIP(E1,L2,E2,L1) EL=L DIPSUM=(F1-F2)*(F1+F2)*(1.0+EL*EL*E1)/(EL*(E1-E2)) RETURN 2 F1=R8FDIP0(E1,L1,E2,L2,1.0D-12) F2=R8FDIP0(E1,L2,E2,L1,1.0D-12) EL=L DIPSUM=(F1-F2)*(F1+F2)*EL*E1/(E1-E2) RETURN END