⟦356c68dfe⟧

TextFile

c
c    program 2
c
c   acqb shell c.f.p.. fractional parentage coefficients for equivalent
c   p shell and equivalent d shell electrons.
c   allison, d.c.s.
c   ref. in comp. phys. commun. 1 (1969) 15
c
      program PSHELLTEST
C
C
C     TO EVALUATE THE F.P. COEFFICIENTS OF ALL POSSIBLE PARENT STATES
C     ALLOWED BY ONE INPUT STATE. THE SUM OF THE SQUARES OF THE ALLOWED
C     COEFFICIENTS IS CHECKED WITH UNITY
C
C
c     set input and output channels
c
      zone readf(2,1,stderror)
      zone writef(150,1,stderror)
      call zassign(readf,1)
      call zassign(writef,7)
c     call open(readf,4,'readf',0)
      call open(writef,4,'writef',0)
c
c
C     INITIALIZE SIX SETS OF INPUT DATA
C
      integer iread,iwrite
      integer N(6),IL(6),IS(6)
      iread=1
      iwrite=7
      n(1)=1
      n(2)=2
      n(3)=3
      n(4)=4
      n(5)=5
      n(6)=6
      il(1)=1
      il(2)=1
      il(3)=2
      il(4)=0
      il(5)=1
      il(6)=0
      is(1)=2
      is(2)=3
      is(3)=2
      is(4)=1
      is(5)=2
      is(6)=1

10    FORMAT (3H N=,I1,2X,4H LI=,I1,2X,4H SI=,I1,12X,4H LJ=,I1,2X,4H SJ=
     1,I1,5X,6H CFPP=,F12.8)
11    FORMAT (3H N=,I1,2X,4H LI=,I1,2X,4H SI=,I1,12X,5H SUM=,F12.8///)
14    FORMAT (24H       STATE IN QUESTION,19H       PARENT STATE)
15    FORMAT (1H1 ,20H P SHELL F.P.C. TEST,////)
      WRITE (iwrite,15)
C
C     TAKE INPUT STATE IN QUESTION FROM DATA STATEMENT
C
      DO 1 I=1,6
      WRITE (iwrite,14)
      SUM = 0.0
C
C     SEARCH FOR ALLOWED PARENT STATES
C
      DO 6 LJ =0,6
      DO 7 ISJ =1,6
      CALL CFPP(N(I),IL(I),IS(I),LJ,ISJ,COEFP)
      IF(COEFP-9.9) 8,7,8
8     SUM =SUM +COEFP**2
      WRITE(iwrite,10) N(I),IL(I),IS(I),LJ,ISJ,COEFP
7     CONTINUE
6     CONTINUE
C
      IF(SUM) 1,1,12
12    write(iwrite,11) n(i),il(i),is(i),sum
1     CONTINUE
      STOP
      END
c
c------------------------------------------------------------------------
c   ▶18◀▶18◀                           cfpp
c-------------------------------------------------------------------------
c
      SUBROUTINE CFPP(N,LI,ISI,LJ,ISJ,COEFP)
C
C     THIS SUBROUTINE EVALUATES THE COEFFICIENTS OF FRACTIONAL PARENTAGE
C     FOR EQUIVALENT P SHELL ELECTRONS FROM TABLES GIVEN IN J.C.SLATER
C     QUANTUM THEORY OF ATOMIC STRUCTURE,VOLUME2,P350(1960)
C     IN THE SUBROUTINE LIST N,THE NO. OF ELECTRONS,L THE ANGULAR
C     MOMENTUM QUANTUM NO.,(2S+1) THE SPIN QUANTUM NO. OF BOTH THE STATE
C     IN QUESTION AND ITS PARENT STATE ARE INPUT PARAMETERS.THE RESULT
C     IS OUTPUT AS COEFP
C
      integer IL(3,3),IS(3,3),ITAB1(3,1),ITAB2(3,3),NORM1(3),NORM2(3)
C
C
C     SET UP P SHELL PARAMETERS AND TABLES
C
      il(1,1)=1
      il(2,1)=1
      il(2,2)=2
      il(2,3)=0
      il(3,1)=0
      il(3,2)=2
      il(3,3)=1
      is(1,1)=2
      is(2,1)=3
      is(2,2)=1
      is(2,3)=1
      is(3,1)=4
      is(3,2)=2
      is(3,3)=2
      itab1(1,1)=1
      itab1(2,1)=1
      itab1(3,1)=1
      itab2(1,1)=1
      itab2(1,2)=0
      itab2(1,3)=0
      itab2(2,1)=1
      itab2(2,2)=-1
      itab2(2,3)=0
      itab2(3,1)=-9
      itab2(3,2)=-5
      itab2(3,3)=4
      norm1(1)=1
      norm1(2)=1
      norm1(3)=1
      norm2(1)=1
      norm2(2)=2
      norm2(3)=18
C
C     TEST IF N IS IN THE FIRST HALF OF SHELL
C
99    IF(N-4) 40,103,103
C
C     TEST IF STATE IN QUESTION IS ALLOWED
C     IF IT IS, IDENTIFY THE ROW OF THE TABLE BY J1
C
40    J = 0
101   J = J+1
      IF(J-4) 41,8,8
41    IF(IL(N,J)-LI) 101,42,101
42    IF(IS(N,J)-ISI) 101,43,101
43    J1 = J
C
C     TEST IF PARENT STATE IS ALLOWED
C     IF IT IS, IDENTIFY THE COLUMN OF THE TABLE BY J2
C
      IF(N-1) 44,70,44
70    IF(LJ) 8,71,8
71    IF(ISJ-1) 8,1,8
44    J = 0
102   J = J+1
      IF(J-4) 45,8,8
45    IF(IL(N-1,J)-LJ) 102,46,102
46    IF(IS(N-1,J)-ISJ) 102,47,102
47    J2 = J
      GO TO 100
C
C     SIMILAR SETTING OF J1 AND J2 IF N IS IN SECOND HALF OF SHELL
C
103   M =6-N
      IF(M) 72,73,72
73    IF(LI) 8,74,8
74    IF(ISI-1) 8,75,8
72    J = 0
104   J = J+1
      IF(J-4) 48,8,8
48    IF(IL(M,J)-LI) 104,49,104
49    IF(IS(M,J)-ISI) 104,50,104
50    J1 = J
75    J = 0
105   J = J+1
      IF(J-4) 51,8,8
51    IF(IL(M+1,J)-LJ) 105,52,105
52    IF(IS(M+1,J)-ISJ) 105,53,105
53    J2 = J
C
C
C     IDENTIFY THE F.P.C AS A UNIQUE ELEMENT OF ITABN(J1,J2)
C
100   GO TO (1,2,3,4,4,1),N
1     COEFP = 1.0
      GO TO 10
2     COEFP = ITAB1(J1,J2)
      IF(COEFP) 54,10,31
54    COEFP = -SQRT(-COEFP/NORM1(J1))
      GO TO 10
31    COEFP = SQRT(COEFP/NORM1(J1))
      GO TO 10
3     COEFP = ITAB2(J1,J2)
      IF(COEFP) 55,10,32
55    COEFP = -SQRT(-COEFP/NORM2(J1))
      GO TO 10
32    COEFP =SQRT(COEFP/NORM2(J1))
      GO TO 10
C
C     USE RECURRENCE RELATION EQUATION (19) OF RACAH FOR SECOND HALF OF
C     SHELL
C
4     ISIGN = (-1)**((ISI+ISJ-5)/2+LI+LJ)
      FACTOR = ((7.0-N)*ISJ*(2*LJ+1.0))/(N*ISI*(2*LI+1.0))
      IF(N-5) 56,5,8
56    COEFP = ITAB2(J2,J1)
      IF(COEFP) 57,10,33
57    COEFP = -SQRT(-COEFP/NORM2(J2))
      GO TO 34
33    COEFP = SQRT(COEFP/NORM2(J2))
34    COEFP = COEFP * ISIGN * SQRT(FACTOR)
      IF(LJ-1) 35,10,35
35    COEFP = -COEFP
      GO TO 10
5     COEFP = ITAB1(J2,J1)
      IF(COEFP) 58,10,36
58    COEFP = -SQRT(-COEFP/NORM1(J2))
      GO TO 37
36    COEFP = SQRT(COEFP/NORM1(J2))
37    COEFP = COEFP * ISIGN * SQRT(FACTOR)
      GO TO 10
C
16    format(37h fail in coefp at 8   unallowed state)
8     write(iwrite,16) 
      pause
C
10    CONTINUE
      RETURN
      END
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦356c68dfe⟧ TextFile

Derivation

TextFile
