threej.bas

Newman程序是一套很好的光谱软件计算程序

DECLARE SUB threej (R0#, AJ1!, AJ2!, AJ3!, AM1!, AM2!, AM3!)
REM  THIS IS A PROGRAM TO CALCULATE THE 3_J SYMBOL
REM    R0 =  (AJ1,AJ2,AJ3;AM1,AM2,AM3)
REM    F(I)=I! IS THE FACTORIAL FUNCTION
REM    I = 0 TO 30 IS USUSALLY ENOUGH
REM    PLEASE NOTE THAT I STRATS FROM ZERO
REM
REM    "CRYSTAL FIELD HANDBOOK", EDITED BY D.J. NEWMAN AND BETTY NG
REM    CAMBRIDGE UNIVERSITY PRESS

	DEFINT J, M
	DEFDBL R
	
	 PRINT "THIS IS A PROGRAM TO CALCULATE THE 3_J SYMBOL"
	 PRINT "  R0 =  (AJ1,AJ2,AJ3;AM1,AM2,AM3)"
	 PRINT "       "
	 PRINT "CRYSTAL FIELD HANDBOOK, EDITED BY D.J. NEWMAN AND BETTY NG"
	 PRINT "  CAMBRIDGE UNIVERSITY PRESS"
	 PRINT "      "
REPEAT:  INPUT " J1 = ?, J2 = ? ,J3 = ?", AJ1, AJ2, AJ3
	 INPUT " M1 = ?, M2 = ? ,M3 = ?", AM1, AM2, AM3

REM CALL THE SUBPROGRAM THREEJ
	 CALL threej(R0, AJ1, AJ2, AJ3, AM1, AM2, AM3)
	 PRINT "THE THREE J SYMBOL IS:", R0
	 PRINT " "

REM  TO CONTINUE OR NOT
      PRINT " DO YOU WANT TO CALCULATE ANOTHER 3-j SYMBOL?"
      INPUT " TYPE IN Y/y (FOR YES), N/n (FOR NO)", QANS$
      IF QANS$ = "Y" OR QANS$ = "y" THEN
	 CLS
	 GOTO REPEAT:
	ELSE
	 GOTO FINISH:
      END IF
FINISH:  END

DEFSNG J, M
SUB threej (R0, AJ1, AJ2, AJ3, AM1, AM2, AM3)
       DEFINT J, M-N
       DEFDBL F, R
       DIM F(0 TO 30)

REM DEFINE THE FACTORIAL FUNCTION
       FOR I = 0 TO 30
	   F(I) = 1
	   FOR J = 1 TO I
	     F(I) = F(I) * J
	   NEXT J
       NEXT I

REM   SELECTION RULES
     IF AM1 + AM2 + AM3 <> 0 THEN GOTO ZERO:
     IF AJ1 + AJ2 - AJ3 < 0 THEN GOTO ZERO:
     IF AJ3 + AJ1 - AJ2 < 0 THEN GOTO ZERO:
     IF AJ3 + AJ2 - AJ1 < 0 THEN GOTO ZERO:
     IF AJ1 + AJ2 + AJ3 + 1 < 0 THEN GOTO ZERO:
     IF AJ1 - AM1 < 0 THEN GOTO ZERO:
     IF AJ2 - AM2 < 0 THEN GOTO ZERO:
     IF AJ3 - AM3 < 0 THEN GOTO ZERO:
     IF AJ1 + AM1 < 0 THEN GOTO ZERO:
     IF AJ2 + AM2 < 0 THEN GOTO ZERO:
     IF AJ3 + AM3 < 0 THEN GOTO ZERO:

   R4 = F(CINT(AJ1 + AJ2 - AJ3)) * F(CINT(AJ1 - AM1)) * F(CINT(AJ2 - AM2)) * F(CINT(AJ3 - AM3)) * F(CINT(AJ3 + AM3))
   R5 = F(CINT(AJ1 + AJ2 + AJ3 + 1)) * F(CINT(AJ3 + AJ1 - AJ2)) * F(CINT(AJ3 + AJ2 - AJ1)) * F(CINT(AJ1 + AM1)) * F(CINT(AJ2 + AM2))
   R6 = 0
   FOR J7 = 0 TO 25
       IF AJ1 + AM1 + J7 < 0 THEN GOTO J7R:
       IF AJ2 + AJ3 - AM1 - J7 < 0 THEN GOTO J7R:
       IF AJ3 + AM3 - J7 < 0 THEN GOTO J7R:
       IF AJ1 - AM1 - J7 < 0 THEN GOTO J7R:
       IF AJ2 - AJ3 + AM1 + J7 < 0 THEN GOTO J7R:
       R8 = F(CINT(AJ1 + AM1 + J7)) * F(CINT(AJ2 + AJ3 - AM1 - J7)) * (-1) ^ (CINT(AJ1 - AM1 - J7))
       R9 = F(J7) * F(CINT(AJ3 + AM3 - J7)) * F(CINT(AJ1 - AM1 - J7)) * F(CINT(AJ2 - AJ3 + AM1 + J7))
       R6 = R6 + R8 / R9
J7R:  NEXT J7
       R0 = SQR(R4 / R5) * R6 * (-1) ^ CINT((AJ1 - AJ2 - AM3))
       GOTO FIN:
ZERO:  R0 = 0
FIN: END SUB