|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 43776 (0xab00)
Types: TextFile
Names: »per23567«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »per23567«
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 INITIALIZE SIX SETS OF INPUT DATA
C
integer iread,iwrite
integer N(6),IL(6),IS(6)
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
C
c set input and output channels
c
iread=1
iwrite=7
zone readf(2,1,stderror)
zone writef(100,1,stderror)
call zassign(readf,1)
call zassign(writef,7)
call open(readf,4,'readfile',0)
call open(writef,4,'writefile',0)
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
c
c program 3
c
c acrna new d shell cfp. a new version of the program to compute
c the fractional parentage coefficients for equivalent d schell
c electrons. chivers, a.t.
c ref. in comp. phys. commun. 6 (1973) 88
program dshell external bldata
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 INITIALIZE TEN SETS OF INPUT DATA
C
DIMENSION N(10),IV(10),IL(10),IS(10)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
n(1)=1
n(2)=2
n(3)=3
n(4)=4
n(5)=5
n(6)=6
n(7)=7
n(8)=8
n(9)=9
n(10)=10
iv(1)=1
iv(2)=2
iv(3)=3
iv(4)=2
iv(5)=5
iv(6)=4
iv(7)=3
iv(8)=2
iv(9)=1
iv(10)=0
il(1)=2
il(2)=2
il(3)=3
il(4)=3
il(5)=4
il(6)=3
il(7)=1
il(8)=1
il(9)=2
il(10)=0
is(1)=2
is(2)=1
is(3)=2
is(4)=3
is(5)=2
is(6)=1
is(7)=4
is(8)=3
is(9)=2
is(10)=1
C
10 FORMAT (3H N=,I1,2X,4H VI=,I1,2X,4H LI=,I1,2X,4H SI=,I1,5X,4H VJ=,
1I1,2X,4H LJ=,I1,2X,4H SJ=,I1,5X,6H CFPD=,F12.8)
11 FORMAT (3H N=,I1,2X,4H VI=,I1,2X,4H LI=,I1,2X,4H SI=,I1,5X,5H SUM=
1,F12.8///)
14 FORMAT (24H STATE IN QUESTION,19H PARENT STATE)
15 FORMAT (1H1 ,20H D SHELL F.P.C. TEST,////)
c
c set input and output channels
c
iread=1
iwrite=7
ipunch=8
zone readf(2,1,stderror)
zone writef(150,1,stderror)
zone punchf(150,1,stderror)
call zassign(readf,1)
call zassign(writef,7)
call zassign(punchf,8)
call open(readf,4,'readfile',0)
call open(writef,4,'writefile',0)
call open(punchfile,4,'punchfile',0)
c
IWRITE=2
WRITE(IWRITE,15)
C
C TAKE INPUT STATE IN QUESTION FROM DATA STATEMENT
C
DO 1 I=1,10
WRITE(IWRITE,14)
SUM = 0.0
C
C SEARCH FOR ALLOWED PARENT STATES
C
DO 5 IVJ1=1,6
IVJ=IVJ1-1
DO 6 LJ1=1,7
LJ=LJ1-1
DO 7 ISJ=1,6
CALL CFPD(N(I),IV(I),IL(I),IS(I),IVJ,LJ,ISJ,COEFP)
IF(COEFP-9.9)8,7,8
8 SUM=SUM +COEFP**2
WRITE(IWRITE,10) N(I),IV(I),IL(I),IS(I),IVJ,LJ,ISJ,COEFP
7 CONTINUE
6 CONTINUE
5 CONTINUE
C
IF(SUM) 1,1,12
12 WRITE(IWRITE,11) N(I),IV(I),IL(I),IS(I),SUM
1 CONTINUE
STOP
END
c
c------------------------------------------------------------------------
c bldata
c-------------------------------------------------------------------------
subroutine bldata
C
COMMON/FRPAR2/I(719)
C
C BLOCK DATA FOR CFPD SUBROUTINE
C
DATA I( 1),I( 2),I( 3),I( 4),I( 5),I( 6),I( 7),I( 8),
1 I( 9),I( 10),I( 11),I( 12),I( 13),I( 14),I( 15),I( 16),
1 I( 17),I( 18),I( 19),I( 20),I( 21),I( 22),I( 23),I( 24),
2 I( 25),I( 26),I( 27),I( 28),I( 29),I( 30),I( 31),I( 32),
3 I( 33),I( 34),I( 35),I( 36),I( 37),I( 38),I( 39),I( 40),
4 I( 41),I( 42),I( 43),I( 44),I( 45),I( 46),I( 47),I( 48),
5 I( 49),I( 50),I( 51),I( 52),I( 53),I( 54),I( 55),I( 56),
6 I( 57),I( 58),I( 59),I( 60),I( 61),I( 62),I( 63),I( 64),
7 I( 65),I( 66),I( 67),I( 68),I( 69),I( 70),I( 71),I( 72),
8 I( 73),I( 74),I( 75),I( 76),I( 77),I( 78),I( 79),I( 80)/
1 1, 5, 8, 16, 16, 1, 2, 3,
1 4, 5, 0, 2, 3, 4, 5, 0,
1 2, 3, 4, 3, 0, 2, 3, 2,
2 5, 0, 0, 3, 4, 3, 0, 0,
3 1, 4, 5, 0, 0, 3, 2, 3,
4 0, 0, 3, 4, 3, 0, 0, 0,
5 4, 5, 0, 0, 0, 2, 3, 0,
6 0, 0, 4, 5, 0, 0, 0, 4,
7 1, 0, 0, 0, 2, 3, 0, 0,
8 0, 4, 5, 0, 0, 0, 0, 3/
DATA I( 81),I( 82),I( 83),I( 84),I( 85),I( 86),I( 87),I( 88),
1 I( 89),I( 90),I( 91),I( 92),I( 93),I( 94),I( 95),I( 96),
1 I( 97),I( 98),I( 99),I(100),I(101),I(102),I(103),I(104),
2 I(105),I(106),I(107),I(108),I(109),I(110),I(111),I(112),
3 I(113),I(114),I(115),I(116),I(117),I(118),I(119),I(120),
4 I(121),I(122),I(123),I(124),I(125),I(126),I(127),I(128),
5 I(129),I(130),I(131),I(132),I(133),I(134),I(135),I(136),
6 I(137),I(138),I(139),I(140),I(141),I(142),I(143),I(144),
7 I(145)/
1 0, 0, 0, 4, 5, 2, 3, 3,
1 2, 0, 0, 1, 1, 5, 4, 0,
1 4, 5, 4, 3, 0, 2, 4, 3,
2 2, 0, 0, 3, 3, 1, 0, 0,
3 2, 2, 6, 0, 0, 2, 1, 5,
4 0, 0, 1, 1, 4, 0, 0, 0,
5 6, 4, 0, 0, 0, 4, 3, 0,
6 0, 0, 4, 3, 0, 0, 0, 3,
7 2/
DATA I(146),I(147),I(148),I(149),I(150),I(151),I(152),I(153),
1 I(154),I(155),I(156),I(157),I(158),I(159),I(160),I(161),
1 I(162),I(163),I(164),I(165),I(166),I(167),I(168),I(169),
2 I(170),I(171),I(172),I(173),I(174),I(175),I(176),I(177),
3 I(178),I(179),I(180),I(181),I(182),I(183),I(184),I(185),
4 I(186),I(187),I(188),I(189),I(190),I(191),I(192),I(193),
5 I(194),I(195),I(196),I(197),I(198),I(199),I(200),I(201),
6 I(202),I(203),I(204),I(205),I(206),I(207),I(208),I(209),
7 I(210),I(211),I(212),I(213),I(214),I(215),I(216),I(217),
8 I(218),I(219),I(220),I(221),I(222),I(223),I(224),I(225)/
1 0, 0, 0, 2, 2, 0, 0, 0,
1 2, 2, 0, 0, 0, 0, 1, 0,
1 0, 0, 0, 0, 2, 3, 4, 5,
2 6, 0, 3, 4, 3, 4, 0, 1,
3 2, 3, 4, 0, 1, 2, 3, 4,
4 0, 1, 2, 3, 4, 0, 0, 2,
5 3, 2, 0, 0, 2, 3, 2, 0,
6 0, 2, 3, 2, 0, 0, 0, 1,
7 2, 0, 0, 0, 1, 2, 0, 0,
8 0, 1, 2, 0, 0, 0, 1, 2/
DATA I(226),I(227),I(228),I(229),I(230),I(231),I(232),I(233),
1 I(234),I(235),I(236),I(237),I(238),I(239),I(240),I(241),
1 I(242),I(243),I(244),I(245),I(246),I(247),I(248),I(249),
2 I(250),I(251),I(252),I(253),I(254),I(255),I(256),I(257),
3 I(258),I(259),I(260),I(261),I(262),I(263),I(264),I(265),
4 I(266),I(267),I(268),I(269),I(270),I(271),I(272),I(273),
5 I(274),I(275),I(276),I(277),I(278),I(279),I(280),I(281),
6 I(282),I(283),I(284),I(285),I(286),I(287),I(288),I(289),
7 I(290)/
1 0, 0, 0, 1, 2, 0, 0, 0,
1 1, 2, 0, 0, 0, 1, 2, 0,
1 0, 0, 1, 2, 1, 1, 1, 1,
2 1, 4, -7, -1, 21, 7, -21, 21,
3 -8, -1, -8, 0, 0, 28, -9, -49,
4 7, 0, 0, 1, 11, -25, -9, -25,
5 0, 0, 0, 0, -10, -10, -5, 45,
6 15, 0, 0, 0, 0, 0, 16, 0,
7 0/
DATA I(291),I(292),I(293),I(294),I(295),I(296),I(297),I(298),
1 I(299),I(300),I(301),I(302),I(303),I(304),I(305),I(306),
1 I(307),I(308),I(309),I(310),I(311),I(312),I(313),I(314),
2 I(315),I(316),I(317),I(318),I(319),I(320),I(321),I(322),
3 I(323),I(324),I(325),I(326),I(327),I(328),I(329),I(330),
4 I(331),I(332),I(333),I(334),I(335),I(336),I(337),I(338),
5 I(339),I(340),I(341),I(342),I(343),I(344),I(345),I(346),
6 I(347),I(348),I(349),I(350),I(351),I(352),I(353),I(354),
7 I(355),I(356),I(357),I(358),I(359),I(360),I(361),I(362),
8 I(363),I(364),I(365),I(366),I(367),I(368),I(369),I(370)/
1 7, 20, -560, 224, -112, -21, -56, 16,
1 0, 0, 0, 0, 0, 0, 0, 0,
1 3, 0, 0, -56, -448, 49, -64, -14,
2 0, 0, 0, 0, 0, 0, 0, 0,
3 0, 26, 308, 110, 220, 0, 0, 0,
4 7, -154, -28, -132, 0, 0, 0, 0,
5 0, -9, 297, 90, -405, 45, 0, 0,
6 3, 66, -507, -3, -60, 15, 0, 0,
7 0, 5, 315, -14, -175, -21, -56, -25,
8 0, 70, 385, -105, 28, 63, 0, 0/
DATA I(371),I(372),I(373),I(374),I(375),I(376),I(377),I(378),
1 I(379),I(380),I(381),I(382),I(383),I(384),I(385),I(386),
1 I(387),I(388),I(389),I(390),I(391),I(392),I(393),I(394),
2 I(395),I(396),I(397),I(398),I(399),I(400),I(401),I(402),
3 I(403),I(404),I(405),I(406),I(407),I(408),I(409),I(410),
4 I(411),I(412),I(413),I(414),I(415),I(416),I(417),I(418),
5 I(419),I(420),I(421),I(422),I(423),I(424),I(425),I(426),
6 I(427),I(428),I(429),I(430),I(431),I(432),I(433),I(434),
7 I(435)/
1 0, 0, 0, 315, 0, 0, 135, 0,
1 0, 189, 0, 0, 105, 0, 1, 0,
1 0, 0, 200, 15, 120, 60, -35, 10,
2 0, -25, 88, 200, 45, 20, 0, 1,
3 0, 0, 0, 16, -200, -14, -14, 25,
4 0, 0, 0, 120, -42, 42, 0, 0,
5 1, -105, -175, -175, -75, 0, 0, 0,
6 0, 0, 0, 0, 0, 0, 0, 0,
7 0/
DATA I(436),I(437),I(438),I(439),I(440),I(441),I(442),I(443),
1 I(444),I(445),I(446),I(447),I(448),I(449),I(450),I(451),
1 I(452),I(453),I(454),I(455),I(456),I(457),I(458),I(459),
2 I(460),I(461),I(462),I(463),I(464),I(465),I(466),I(467),
3 I(468),I(469),I(470),I(471),I(472),I(473),I(474),I(475),
4 I(476),I(477),I(478),I(479),I(480),I(481),I(482),I(483),
5 I(484),I(485),I(486),I(487),I(488),I(489),I(490),I(491),
6 I(492),I(493),I(494),I(495),I(496),I(497),I(498),I(499),
7 I(500),I(501),I(502),I(503),I(504),I(505),I(506),I(507),
8 I(508),I(509),I(510),I(511),I(512),I(513),I(514),I(515)/
1 154, -110, 0, 0, 231, 286, 924, -308,
1 220, -396, 0, 0, 0, 0, 0, 0,
1 -66, -90, 180, 0, 99, -99, 891,-5577,
2 -405, -9, 0, 45, 45, 0, 0, 0,
3 0, 224, 0, -56, 0, -220, 1680, 0,
4 112, 0, -21, 21, 0, -16, 0, 0,
5 -70, 14, -84, 56, 0, 55, 945, 4235,
6 -175, -315, 0, -21, 189, -25, 0, 0,
7 25, -15, -135, 35, 0, 0, 600, 968,
8 120, 600, 0, 60, 60, 10, 3, 0/
DATA I(516),I(517),I(518),I(519),I(520),I(521),I(522),I(523),
1 I(524),I(525),I(526),I(527),I(528),I(529),I(530),I(531),
1 I(532),I(533),I(534),I(535),I(536),I(537),I(538),I(539),
2 I(540),I(541),I(542),I(543),I(544),I(545),I(546),I(547),
3 I(548),I(549),I(550),I(551),I(552),I(553),I(554),I(555),
4 I(556),I(557),I(558),I(559),I(560),I(561),I(562),I(563),
5 I(564),I(565),I(566),I(567),I(568),I(569),I(570),I(571),
6 I(572),I(573),I(574),I(575),I(576),I(577),I(578),I(579),
7 I(580)/
1 0, -56, 0, -64, 0, 0, 0, 0,
1 448, 0, -9, -49, 0, 14, 0, 0,
1 0, -16, 126, 14, 0, 0, 0, 0,
2 -200, 360, 0, -14, 126, 25, 0, 0,
3 0, 0, 0, 0, -175, 182, -728,-2184,
4 0, 0, 0, 0, 0, 0, 0, 0,
5 0, 0, 0, 0, 0, 220, 880, 0,
6 -400, 0, -9, -25, 0, 0, 0, 0,
7 0/
DATA I(581),I(582),I(583),I(584),I(585),I(586),I(587),I(588),
1 I(589),I(590),I(591),I(592),I(593),I(594),I(595),I(596),
1 I(597),I(598),I(599),I(600),I(601),I(602),I(603),I(604),
2 I(605),I(606),I(607),I(608),I(609),I(610),I(611),I(612),
3 I(613),I(614),I(615),I(616),I(617),I(618),I(619),I(620),
4 I(621),I(622),I(623),I(624),I(625),I(626),I(627),I(628),
5 I(629),I(630),I(631),I(632),I(633),I(634),I(635),I(636),
6 I(637),I(638),I(639),I(640),I(641),I(642),I(643),I(644),
7 I(645),I(646),I(647),I(648),I(649),I(650),I(651),I(652),
8 I(653),I(654),I(655),I(656),I(657),I(658),I(659),I(660)/
1 0, 0, 0, -45, -5, 845,-1215, 275,
1 495, 0, -11, 99, 0, 0, 0, 0,
1 0, 0, 0, 0, 33, -7,-2541, 105,
2 -525, 0, 35, 35, -15, 0, 0, 0,
3 0, 0, 0, 0, 0, -800, 0, -160,
4 0, -5, 45, 0, 30, 0, 0, 0,
5 0, 0, 0, 0, 0, -100, 1452, 180,
6 -100, 0, -10, 90, 15, -2, 0, 0,
7 0, 0, 0, 0, 0, 0, 0, 0,
8 0, 6, 0, 0, 0, 0, 0, 0/
DATA I(661),I(662),I(663),I(664),I(665),I(666),I(667),I(668),
1 I(669),I(670),I(671),I(672),I(673),I(674),I(675),I(676),
1 I(677),I(678),I(679),I(680),I(681),I(682),I(683),I(684),
2 I(685),I(686),I(687),I(688),I(689),I(690),I(691),I(692),
3 I(693),I(694),I(695),I(696),I(697),I(698),I(699),I(700),
4 I(701),I(702),I(703),I(704),I(705),I(706),I(707),I(708),
5 I(709),I(710),I(711),I(712),I(713),I(714),I(715),I(716),
6 I(717),I(718),I(719)/
1 0, 0, 0, 0, 0, 0, 0, 0,
1 0, 0, -14, -56, 0, 0, 1, 1,
1 1, 1, 1, 5, 15, 2, 42, 70,
2 60, 140, 30, 10, 60, 1680, 840, 1680,
3 210, 360, 90, 10, 504, 1008, 560, 280,
4 140, 1, 1, 1, 420, 700, 700, 300,
5 550, 1100, 8400,18480, 2800, 2800, 50, 350,
6 700, 150, 5/
C
END
c
c----------------------------------------------------------------------
c cfpd
c-----------------------------------------------------------------------
c
SUBROUTINE CFPD(N,IVI,LI,ISI,IVJ,LJ,ISJ,COEFP)
C
C
C THIS SUBROUTINE EVALUATES THE COEFFICIENTS OF FRACTIONAL PARENTAGE
C FOR EQUIVALENT D 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,V THE SENIORITY QUAN
C TUM NO.,L THE ANGULAR MOMENTUM QUANTUM NO.,(2S+1) THE SPIN QUANTUM
C NO. OF BOTH THE STATE IN QUESTION AND ITS PARENT STATE ARE INPUT
C PARAMETERS THE RESULT IS OUTPUT AS COEFP
C
COMMON/FRPAR2/K(5),IV(5,16),IL(5,16),IS(5,16),ITAB1(5,1),ITAB2(8,5
1 ),ITAB3(16,8),ITAB4(16,16),NORM1(5),NORM2(8),NORM3(16),NORM4(16)
COMMON/INFORM/IREAD,IWRITE,IPUNCH
C
C
C TEST IF N IS IN THE FIRST HALF OF SHELL
C
99 IF(N-6) 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-17) 41,11,11
41 IF(IV(N,J)-IVI) 101,42,101
42 IF(IL(N,J)-LI) 101,43,101
43 IF(IS(N,J)-ISI) 101,44,101
44 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) 45,30,45
30 IF(IVJ) 11,31,11
31 IF(LJ) 11,32,11
32 IF(ISJ-1) 11,1,11
45 J = 0
102 J = J+1
IF(J-17) 46,11,11
46 IF(IV(N-1,J)-IVJ) 102,47,102
47 IF(IL(N-1,J)-LJ) 102,48,102
48 IF(IS(N-1,J)-ISJ) 102,49,102
49 J2=J
GO TO 100
C
C SIMILAR SETTING OF J1 AND J2 IF N IS IN SECOND HALF OF SHELL
C
103 M = 10-N
IF(M) 36,33,36
33 IF(IVI) 11,34,11
34 IF(LI) 11,35,11
35 IF(ISI-1) 11,37,11
36 J = 0
104 J = J+1
IF(J-17) 50,11,11
50 IF(IV(M,J)-IVI) 104,51,104
51 IF(IL(M,J)-LI) 104,52,104
52 IF(IS(M,J)-ISI) 104,53,104
53 J1=J
37 J = 0
105 J = J+1
IF(J-17) 54,11,11
54 IF(IV(M+1,J)-IVJ) 105,55,105
55 IF(IL(M+1,J)-LJ) 105,56,105
56 IF(IS(M+1,J)-ISJ) 105,57,105
57 J2=J
C
C IDENTIFY THE F.P.C AS A UNIQUE ELEMENT OF ITABN(J1,J2)
C
100 GO TO (1,2,3,4,5,12,12,12,12,1),N
1 COEFP = 1.0
GO TO 10
2 COEFP = ITAB1(J1,J2)
IF(COEFP) 60,10,81
60 COEFP = - SQRT(-COEFP/NORM1(J1))
GO TO 10
81 COEFP = SQRT(COEFP/NORM1(J1))
GO TO 10
3 COEFP = ITAB2(J1,J2)
IF(COEFP) 61,10,82
61 COEFP = -SQRT(-COEFP/NORM2(J1))
GO TO 10
82 COEFP = SQRT(COEFP/NORM2(J1))
GO TO 10
4 COEFP = ITAB3(J1,J2)
IF(COEFP) 62,10,83
62 COEFP = -SQRT(-COEFP/NORM3(J1))
GO TO 10
83 COEFP = SQRT(COEFP/NORM3(J1))
GO TO 10
5 COEFP = ITAB4(J1,J2)
IF(COEFP) 63,10,84
63 COEFP = -SQRT(-COEFP/NORM4(J1))
GO TO 10
84 COEFP = SQRT(COEFP/NORM4(J1))
GO TO 10
C
C USE RECURRENCE RELATION EQUATION (19) OF RACAH FOR SECOND HALF OF
C SHELL
C
12 ISIGN = (-1)**((ISI+ISJ-7)/2 +LI +LJ)
FACTOR = SQRT(((11.0-N)*ISJ*(2*LJ+1.0))/(N*ISI*(2*LI+1.0)))
M1 =N-5
GO TO(6,7,8,9),M1
6 COEFP = ITAB4(J2,J1)
IF(COEFP) 64,10,85
64 COEFP = -SQRT(-COEFP/NORM4(J2))
GO TO 86
85 COEFP = SQRT(COEFP/NORM4(J2))
86 COEFP = COEFP*ISIGN*FACTOR
IF(MOD((IVJ-1)/2,2)) 87,10,87
87 COEFP = -COEFP
GO TO 10
7 COEFP = ITAB3(J2,J1)
IF(COEFP) 65,10,88
65 COEFP = -SQRT(-COEFP/NORM3(J2))
GO TO 89
88 COEFP = SQRT(COEFP/NORM3(J2))
89 COEFP = COEFP * ISIGN * FACTOR
GO TO 10
8 COEFP = ITAB2(J2,J1)
IF(COEFP) 66,10,90
66 COEFP = -SQRT(-COEFP/NORM2(J2))
GO TO 91
90 COEFP = SQRT(COEFP/NORM2(J2))
91 COEFP = COEFP * ISIGN * FACTOR
GO TO 10
9 COEFP = ITAB1(J2,J1)
IF(COEFP) 67,10,92
67 COEFP = -SQRT(-COEFP/NORM1(J2))
GO TO 93
92 COEFP = SQRT(COEFP/NORM1(J2))
93 COEFP = COEFP * ISIGN * FACTOR
GO TO 10
C
106 FORMAT(37H FAIL IN CFPD AT 11 UNALLOWED STATE)
11 WRITE(IWRITE,106)
PAUSE
C
10 CONTINUE
RETURN
END
FINISH
c
c program 5
c
c abkdritz combination principle. program for fitting transition
c energies into a level according to the combination principle.
c williams, i.r.
c ref. in comp. phys. commun. 1 (1970) 465
C
program ritz
C PROGRAM TO FIND ENERGY LEVELS
C (UTILISING THE RITZ COMBINATION PRINCIPLE).
C TO RUN ON THE ORNL IBM 360/91
C
C
REAL LEVEL(100)
DIMENSION GAMMA(300)
C
C READ BEGINNING ENERGY E, DECREMENTAL ENERGY DELTE,
C NUMBER OF STEPS NITER, UNCERTAINTY IN LEVEL ENERGY DLVL,
C NUMBER OF GAMMAS NGAMA, UNCERTAINTY IN GAMMA ENERGY DGAM,
C NUMBER OF LEVELS NLEVL, . . . ALL ON ONE DATA CARD.
C READ GAMMA(I) FROM NEXT CARDS
C READ LEVEL(J) FROM FINAL CARDS
s
c set input and output channels
c
iread=1
iwrite=7
zone readf(50,1,stderror)
zone writef(200,1,stderror)
call zassign(readf,1)
call zassign(writef,7)
call open(readf,4,'readf',0)
call open(writef,4,'writef',0)
c
C
READ (iread,1) E,DELTE,NITER,NGAMA,NLEVL,DLVL,DGAM
1 FORMAT (2F6.2,3I6,2F6.2)
READ (iread,2) (GAMMA(I),I=1,NGAMA)
READ (iread,2) (LEVEL(J),J=1,NLEVL)
2 FORMAT (12F6.1)
WRITE (6,3) E,DELTE,NITER,NGAMA,NLEVL,DLVL,DGAM,(LEVEL(J),J=1,
C NLEVL)
3 FORMAT (1H1,56H E DELTE NITER NGAMMA NLEVEL DLVL
C DGAM//2F8.1,3I8,2F8.1///16H ENERGY LEVELS //(12F8.1/))
WRITE (iwrite,4) (GAMMA(I),I=1,NGAMA)
4 FORMAT (///17H PHOTON ENERGIES //(12F8.1/))
WRITE (iwrite,7)
7 FORMAT (1H ,//31H E LEVEL LEVEL(K) +,17X,11HLEVEL(KJ)
C-,16X,11HGAMMA(IJ) +/27X,8HGAMMA(L),17X,9HGAMMA(LI),18X,9HGAMMA(II
C)/)
C
C DOES E EQUAL A LEVEL ENERGY
C
N = 1
20 M = 0
DO 30 J = 1,NLEVL
IF (E - LEVEL(J) - DLVL)40,40,30
40 IF (E - LEVEL(J) + DLVL)30,60,60
30 CONTINUE
44 WRITE (iwrite,45) E
45 FORMAT (F8.1)
GO TO 100
60 M = M + 1
WRITE (iwrite,64) E,LEVEL(J)
64 FORMAT (2F8.1)
100 CONTINUE
C
C DOES E = LEVEL(K) + GAMMA(L)
C
DO 200 K = 1,NLEVL
DO 200 L = 1,NGAMA
IF (E - LEVEL(K)-DLVL - GAMMA(L)-DGAM)170,170,200
170 IF (E - LEVEL(K)+DLVL - GAMMA(L)+DGAM)200,190,190
190 IF (M - 1)198,196,198
196 W = LEVEL(J) - LEVEL(K) - GAMMA(L)
WRITE (iwrite,197) LEVEL(K),GAMMA(L),W
197 FORMAT (19X,F8.1,2H +,F7.1,2X,1H(,F5.2,1H))
GO TO 200
198 WRITE (iwrite,199) LEVEL(K),GAMMA(L)
199 FORMAT (19X,F8.1,2H +,F7.1)
200 CONTINUE
C
C DOES E = LEVEL(KJ) - GAMMA(LI)
C
DO 300 KJ = 1,NLEVL
DO 300 LI = 1,NGAMA
IF (E - LEVEL(KJ)-DLVL + GAMMA(LI)-DGAM)270,270,300
270 IF (E - LEVEL(KJ)+DLVL + GAMMA(LI)+DGAM)300,290,290
290 IF (M - 1)298,296,298
296 X = LEVEL(J) - LEVEL(KJ) + GAMMA(LI)
WRITE (iwrite,297) LEVEL(KJ),GAMMA(LI),X
297 FORMAT (45X,F8.1,2H -,F7.1,2X,1H(,F5.2,1H))
GO TO 300
298 WRITE (iwrite,299) LEVEL(KJ),GAMMA(LI)
299 FORMAT (45X,F8.1,2H -,F7.1)
300 CONTINUE
C
C DOES E = GAMMA(II) + GAMMA(IJ)
C
DO 400 IJ = 1,NGAMA
IJ1 = IJ + 1
DO 400 II = IJ1,NGAMA
IF (E - GAMMA(II)-DGAM - GAMMA(IJ)-DGAM)370,370,400
370 IF (E - GAMMA(II)+DGAM - GAMMA(IJ)+DGAM)400,390,390
390 IF (M - 1)398,396,398
396 Y = LEVEL(J) - GAMMA(IJ) - GAMMA(II)
WRITE (iwrite,397) GAMMA(IJ),GAMMA(II),Y
397 FORMAT (72X,F8.1,2H +,F7.1,2X,1H(,F5.2,1H))
GO TO 400
398 WRITE (iwrite,399) GAMMA(IJ),GAMMA(II)
399 FORMAT (72X,F8.1,2H +,F7.1)
400 CONTINUE
C
E = E - DELTE
N = N + 1
IF (N - NITER) 20,20,500
500 CALL EXIT
END
c
c program 6
c
c abwahydrogenic interaction integral. a program to calkulate
c the radial parts of the interaktion matrix elements between
c two hydrogen matrix elements between two hydrogenic wave
c functions as power series. jamieson, m.j.
c ref. in comp. phys. commun. 1 (1970) 437.
C
program hydr
C THIS PROGRAM TESTS SUBROUTINE HYD FOR HYDROGENIC WAVE FUNCTION
C INTEGRAL.
C
C THE PURPOSE OF SUBROUTINE HYD IS EXPLAINED AT THE BEGINNING OF IT'S
C LISTING.
C
C READS NA,LA,ZA,NB,LB,ZB,LAMBDA,IPRINT IN FORMAT(2I5,F5.1,2I5,F5.1,2I5)
C
C THE POWERS AND COEFFICIENTS IN THE HYDROGENIC WAVE FUNCTIONS AND IN
C THE INTEGRAL ARE PRINTED IF AND ONLY IF IPRINT = 1.
C
C THE PROGRAM HYDR CALLS SUBROUTINE HYD.
C THE SUBROUTINE HYD CALLS THE SUBROUTINE HYDRO.
C
C ATOMIC UNITS ARE USED THROUGHOUT.
C
C iread, iwrite ARE INPUT AND OUTPUT CHANNEL NUMBERS RESPECTIVELY
C
DIMENSION F(100),IPOWER(100)
COMMON/INPOUT/iread,iwrite
C
C SET INPUT, OUTPUT CHANNEL NUMBERS
C
iread=1
iwrite=7
WRITE(iwrite,98)
READ(iread,99) NA,LA,ZA,NB,LB,ZB,LAMBDA,IPRINT
CALL HYD(NA,LA,ZA,NB,LB,ZB,LAMBDA,IPRINT,FNOUT,LAM1,GAMMA,F,IPOWER
1)
98 FORMAT(1H1,116(1H*))
99 FORMAT(2I5,F5.1,2I5,F5.1,2I5)
CALL EXIT
END
c
c------------------------------------------------------------------
c h y d
c------------------------------------------------------------------
c
SUBROUTINE HYD(NA,LA,ZA,NB,LB,ZB,LAMBDA,IPRINT,FNOUT,LAM1,GAMMA,F,
1POWER)
C
C THE INTEGRAL
C
C I = INTEGRAL(DX)*RAD(NA,LA,ZA/X)*((X1**LAMBDA)/(X2**(LAMBDA+1)))*
C RAD(NB,LB,ZB/X)*(X**2)
C
C WHERE X1 AND X2 ARE THE SMALLER AND LARGER OF X AND R, AND
C RAD(N,L,Z/X) DENOTES THE RADIAL PART OF THE HYDROGENIC WAVE FUNCTION
C (NLM) FOR NUCLEAR CHARGE Z, X BEING THE RADIAL COORDINATE, MAY BE
C WRITTEN IN THE FORM
C
C I = SUM(J)(F(J)*(R**(J-LAMBDA-2)*EXP(-R/GAMMA))
C + FNOUT*(R**(-LAMBDA-1))
C
C WHERE THE SUM OVER J RUNS FROM 1 TO (NA+NB+LAMBDA+1). THIS ROUTINE
C CALCULATES THE COEFFICIENTS F, FNOUT AND GAMMA.
C AT THE COMPLETION OF THIS ROUTINE
C FNOUT WILL BE IN STORE FNOUT
C -LAMBDA-1 WILL BE IN STORE LAM1
C GAMMA WILL BE IN STORE GAMMA
C F WILL BE IN STORE F(J)
C J-LAMBDA-2 WILL BE IN STORE IPOWER(J)
C
C THE INTEGRAL IS NEEDED IN THE CALCULATION OF THE MATRIX ELEMENT
C
C ((NA,LA,MA,ZA/X)/(1/MOD(X-R))/(NB,LB,MB,ZB/X))
C
C WHERE (N,L,M/R) DENOTES A HYDROGENIC WAVE FUNCTION. 1/MOD(X-R) MAY BE
C EXPANDED IN TERMS OF THE SPHERICAL HARMONICS OF THE VECTORS X AND R
C AND THE RADIAL COORDINATES X AND R.
C
C THE PROGRAM IS SET UP FOR A MAXIMUM VALUE FOR NA+NB+LAMBDA+1 OF 100
C IN IT'S DIMENSION STATEMENTS. FOR LARGER VALUES OF THIS INCREASE THE
C DIMENSIONS OF A, B, C, D, E, F, FAC, GAM AND IPOWER.
C
C THE POWERS AND COEFFICIENTS IN THE HYDROGENIC WAVE FUNCTIONS AND IN
C THE INTEGRAL ARE PRINTED IF AND ONLY IF IPRINT = 1.
C
C THE SUBROUTINE HYD CALLS THE SUBROUTINE HYDRO.
C
C ATOMIC UNITS ARE USED THROUGHOUT.
C
C IR, IW ARE INPUT AND OUTPUT CHANNEL NUMBERS RESPECTIVELY
C
DIMENSION A(100),B(100),C(100),D(100),E(100),F(100),GAM(100),
1IPOWER(100)
COMMON/FACT/FAC(100)
COMMON/INPOUT/iread,iwrite
C
C CALCULATE FACTORIALS. FAC(N) IS FACTORIAL(N-1)
C
NN3 = 3*(NA+NB)
FAC(1) = 1.0
DO 10 I = 2,NN3
10 FAC(I) = FAC(I-1)*FLOAT(I-1)
C
C CALCULATE COEFFICIENTS IN HYDROGENIC WAVE FUNCTIONS.
C A AND B ARE COEFFICIENTS IN THE HYDROGENIC WAVE FUNCTIONS.
C
CALL HYDRO(NA,LA,ZA,ALPHA,A,AA,IPRINT)
CALL HYDRO(NB,LB,ZB,BETA,B,BB,IPRINT)
C
C CALCULATE MISCELLANEOUS CONSTANTS
C
LAM = LAMBDA
NAB = NA+NB
LAM1 = -LAM-1
LL1 = LA+LB+1
LL2 = LA+LB+2
NLAM1 = NA+NB+LAM+1
NLAM2 = NA+NB-LAM
LA1 = LA-1
I2LAM1 = 2*LAM+1
I2LAM2 = 2*LAM+2
GAMMA = ALPHA*BETA/(ALPHA+BETA)
C
C CALCULATE POWERS OF GAMMA
C
GAM(1) = GAMMA
DO 9 I = 2,NN3
9 GAM(I) = GAM(I-1)*GAMMA
C
C CALCULATE C
C C, D, AND E ARE INTERMEDIATE QUANTITIES IN THE CALCULATION.
C
DO 30 IT = 1,LL1
30 C(IT) = 0.0
DO 11 IT = LL2,NAB
C(IT) = 0.0
IR1 = MAX0(LA+1,IT-NB)
IR2 = MIN0(NA,IT-LB-1)
DO 12 IX = IR1,IR2
12 C(IT) = C(IT)+A(IX)*B(IT-IX)
11 CONTINUE
C
C CALCULATE FNOUT
C
FNOUT = 0.0
DO 13 IT = LL2,NAB
13 FNOUT = FNOUT+C(IT)*FAC(IT+LAM+1)*GAM(IT+LAM+1)
FNOUT = FNOUT*AA*BB
IF(ABS(FNOUT).LE.1.0E-12) 1,2
1 FNOUT = 0.0
2 CONTINUE
C
C CALCULATE D
C
DO 14 IU = 1,NLAM1
D(IU) = 0.0
IU1 = IU-1-LAM
IUM = MAX0(LL2,IU1)
DO 15 IT = IUM,NAB
15 D(IU)=D(IU)-C(IT)*FAC(1+IT+LAM)*GAM(IT+LAM+2)/(FAC(IU)*GAM(IU))
14 CONTINUE
C
C CALCULATE E
C
DO 16 IU = 1,NLAM2
E(IU) = 0.0
IU1 = IU+LAM
IUM = MAX0(LL2,IU1)
DO 17 IT = IUM,NAB
17 E(IU) = E(IU)+C(IT)*FAC(IT-LAM)*GAM(IT+1)/(FAC(IU)*GAM(IU+LAM))
16 CONTINUE
C
C CALCULATE F AND SET UP TABLE OF POWERS OF R
C
DO 18 IV = 1,I2LAM1
IPOWER(IV) = IV-LAM-2
F(IV) = D(IV)*AA*BB
IF(ABS(F(IV)).LE.1.0E-12) 3,4
3 F(IV) = 0.0
4 CONTINUE
18 CONTINUE
DO 19 IV = I2LAM2,NLAM1
IPOWER(IV) = IV-LAM-2
F(IV) = (D(IV)+E(IV-2*LAM-1))*AA*BB
IF(ABS(F(IV)).LE.1.0E-12) 5,6
5 F(IV) = 0.0
6 CONTINUE
19 CONTINUE
C
C OUTPUT OF COEFFICIENTS, POWERS AND EXPONENTIAL COEFFICIENT
C
IF(IPRINT.EQ.1) 7,8
7 WRITE(iwrite,100) NA,LA,ZA,NB,LB,ZB,LAM,GAMMA,LAM1,FNOUT,(IPOWER
1(IV),F(IV),IV = 1,NLAM1)
WRITE(iwrite,101)
8 RETURN
100 FORMAT(/84H INTEGRAL(DX)*RAD(NA,LA,ZA/X)*((X1**LAMBDA)/(X2**(LAMBD
1A+1)))*RAD(NB,LB,ZB/X)*(X**2)//118H WHERE RAD(N,L,Z/X) DENOTES THE
2 RADIAL PART OF A HYDROGENIC WAVE FUNCTION, AND X1 AND X2 ARE THE
3SMALLER AND LARGER OF/36H X AND R, MAY BE WRITTEN IN THE FORM//
470H INTEGRAL = SUM(J)(F(J)*(R**IPOWER(J)))*EXP(-R/GAMMA))+FNOUT*(R
5**LAM1)//51H WHERE IPOWER(J) = J-LAMBDA-1 AND LAM1 = -LAMBDA-1.//
652H QUANTUM NUMBERS, NUCLEAR CHARGES AND LAMBDA FOLLOW./24H QUA
7NTUM NUMBER NA = ,I2/24H QUANTUM NUMBER LA = ,I2/24H NUCLEAR
8 CHARGE ZA = ,F4.1/24H QUANTUM NUMBER NB = ,I2/24H QUANTUM N
9UMBER LB = ,I2/24H NUCLEAR CHARGE ZB = ,F4.1/15X,9HLAMBDA = ,I2
1 //50H EXPONENTIAL FACTOR IS EXP(-R/GAMMA) WITH GAMMA = ,E13.6/47H
2 POWER OF R (LAM1) IN NON EXPONENTIAL TERM = , I3/48H COEFFICIEN
3T (FNOUT) OF NON EXPONENTIAL TERM = ,E13.6// 61H THE OTHER POWER
4S (IPOWER(J)) AND COEFFICIENTS (F(J)) FOLLOW./2X,5HPOWER,4X,11HCOE
5FFICIENT/(2X,I3,5X,E13.6)/)
101 FORMAT(/1X,116(1H*)/)
END
c
c-----------------------------------------------------------------
c h y d r o
c-----------------------------------------------------------------
c
SUBROUTINE HYDRO(N,L,Z,ALPHA,A,AA,IPRINT)
C
C THIS ROUTINE CACULATES POWERS OF R, THE RADIAL COORDINATE, THEIR
C COEFFICIENTS AND THE COEFFICIENT IN THE EXPONENTIAL TERM FOR THE
C RADIAL PART OF A HYDROGENIC WAVE FUNCTION (NLM) WITH NUCLEAR CHARGE Z.
C
C THE WAVE FUNCTION, RAD(N,L,Z/R) (R(N,L/R) IN EYRING, WALTER AND
C KIMBALL'S NOTATION HAS THE FORM
C
C AA*(SUM(J)(A(J)*(R**J)))*EXP(-R/ALPHA)/R WHERE AA IS SUCH THAT
C A(N) = 1.0, AND ALPHA = N/Z.
C
C THE A'S ARE PROPORTIONAL TO THE LAGUERRE POLYNOMIAL COEFFICIENTS.
C
C THIS ROUTINE COULD BE USED BY ITSELF IF A LINE TO CALCULATE FAC(N) =
C FACTORIAL(N-1) WERE ADDED.
C
C THE POWERS AND COEFFICIENTS ARE PRINTED IF AND ONLY IF IPRINT = 1.
C
C ATOMIC UNITS ARE USED THROUGHOUT.
C
C IR, IW ARE INPUT AND OUTPUT CHANNEL NUMBERS RESPECTIVELY
C
DIMENSION A(100)
COMMON/INPOUT/iread,iwrite
COMMON/FACT/FAC(100)
A(N) = 1.0
IF(N-L-1) 1,3,2
1 WRITE(iwrite,99)
99 FORMAT(34H ERROR. N WAS LESS THAN L+1. EXIT.)
CALL EXIT
2 NL1 = N-L-1
DO 20 I = 1,NL1
20 A(N-I) = -A(N-I+1)*FLOAT((L+N+1-I)*(N-L-I)*N)/FLOAT(2*I)
3 IF(L.EQ.0) 6,7
7 DO 21 I = 1,L
21 A(I) = 0.0
6 CONTINUE
C
C CALCULATE OUTSIDE FACTOR AA
C
AA = -SQRT((Z)/((FAC(N+L+1)*FAC(N-L))))*((2.0*Z/FLOAT(N))**N)/FLOA
1T(N)
NA = (N-L)/2
IF(2*NA+L-N) 4,5,4
4 AA = -AA
5 CONTINUE
C
C EXPONENTIAL COEFFICIENT
C
ALPHA = FLOAT(N)/Z
C
C OUTPUT OF COEFFICIENTS, POWERS AND EXPONENTIAL COEFFICIENT
C
IF(IPRINT.EQ.1) 8,9
8 WRITE(iwrite,101) Z,N,L,ALPHA,AA,(I,A(I),I = 1,N)
WRITE(IW,102)
101 FORMAT(/45H HYDROGEN WAVE FUNCTION --- NUCLEAR CHARGE = ,F4.1/
129H QUANTUM NUMBERS N AND L ARE ,2I3//99H THE INFORMATION GIVEN RE
2FERS TO R*RADIAL PART OF THE WAVE FUNCTION, R BEING THE RADIAL COO
3RDINATE.//48H THE EXPONENTIAL FACTOR IS R/ALPHA WITH ALPHA = ,E13.
46//76H THE OUTSIDE CONSTANT (ARRANGED SO THAT THE COEFFICIENT OF R
5**N IS UNITY) = , E13.6/78H I.E. ALL COEFFICIENTS SHOULD BE MULTIP
6LIED BY THIS CONSTANT IN A CALCULATION./90H THE WAVE FUNCTION HAS
7THE FORM (OUTSIDE FACTOR)*(POWER SERIES IN R)*(EXPONENTIAL FACTOR)
8.//36H THE POWERS AND COEFFICIENTS FOLLOW./2X,5HPOWER,4X,11HCOEFFI
9CIENT/(2X,I3,5X,E13.6)/)
102 FORMAT(/1X,116(1H-))
9 RETURN
END
c
c program 7
c
c acqcd shell c.f.p.. fractional parentage coefficients for
c equivalent p shell and equivalent d shell electrons.
c allison, d.c.s.
c ref. in comp. phys. commun. 1 (1969) 16.
program DSHELLTEST
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 INITIALIZE TEN SETS OF INPUT DATA
C
integer iwrite,iread
iread=5
iwrite=6
DIMENSION N(10),IV(10),IL(10),IS(10)
n(1)=1
n(2)=2
n(3)=3
n(4)=4
n(5)=5
n(6)=6
n(7)=7
n(8)=8
n(9)=9
n(10)=10
iv(1)=1
iv(2)=2
iv(3)=3
iv(4)=2
iv(5)=5
iv(6)=4
iv(7)=3
iv(8)=2
iv(9)=1
iv(10)=0
il(1)=2
il(2)=2
il(3)=3
il(4)=3
il(5)=4
il(6)=3
il(7)=1
il(8)=1
il(9)=2
il(10)=0
is(1)=2
is(2)=1
is(3)=2
is(4)=3
is(5)=2
is(6)=1
is(7)=4
is(8)=3
is(9)=2
is(10)=1
9 N(10),IV(10),IL(10),IS(10)/10,0,0,1/
C
10 FORMAT (3H N=,I1,2X,4H VI=,I1,2X,4H LI=,I1,2X,4H SI=,I1,5X,4H VJ=,
1I1,2X,4H LJ=,I1,2X,4H SJ=,I1,5X,6H CFPD=,F12.8)
11 FORMAT (3H N=,I1,2X,4H VI=,I1,2X,4H LI=,I1,2X,4H SI=,I1,5X,5H SUM=
1,F12.8///)
14 FORMAT (24H STATE IN QUESTION,19H PARENT STATE)
15 FORMAT (1H1 ,20H D SHELL F.P.C. TEST,////)
WRITE (iwrite,15)
C
C TAKE INPUT STATE IN QUESTION FROM DATA STATEMENT
C
DO 1 I=1,10
WRITE (iwrite,14)
SUM = 0.0
C
C SEARCH FOR ALLOWED PARENT STATES
C
DO 5 IVJ =0,5
DO 6 LJ =0,6
DO 7 ISJ =1,6
CALL CFPD(N(I),IV(I),IL(I),IS(I),IVJ,LJ,ISJ,COEFP)
IF(COEFP-9.9) 8,7,8
8 SUM =SUM +COEFP**2
WRITE (iwrite,10) N(I),IV(I),IL(I),IS(I),IVJ,LJ,ISJ,COEFP
7 CONTINUE
6 CONTINUE
5 CONTINUE
C
IF(SUM) 1,1,12
12 write(iwrite,11) n(i),iv(i),il(i),is(i),sum
1 CONTINUE
STOP
END
c
c------------------------------------------------------------------------
c c f p d
c------------------------------------------------------------------------
c
SUBROUTINE CFPD(N,IVI,LI,ISI,IVJ,LJ,ISJ,COEFP)
C
C
C THIS SUBROUTINE EVALUATES THE COEFFICIENTS OF FRACTIONAL PARENTAGE
C FOR EQUIVALENT D 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,V THE SENIORITY QUAN
C TUM NO.,L THE ANGULAR MOMENTUM QUANTUM NO.,(2S+1) THE SPIN QUANTUM
C NO. OF BOTH THE STATE IN QUESTION AND ITS PARENT STATE ARE INPUT
C PARAMETERS THE RESULT IS OUTPUT AS COEFP
C
C
DIMENSION K(5),IV(5,16),IL(5,16),IS(5,16),
1 ITAB1(5,1),ITAB2(8,5),ITAB3(16,8),ITAB4(16,16),
2 NORM1(5),NORM2(8),NORM3(16),NORM4(16)
C
21 FORMAT (5I2)
22 FORMAT (46I1)
23 FORMAT (5I1)
24 FORMAT (15I4)
25 FORMAT (12I5)
26 FORMAT (8I3)
C
IF(RINDEX-99.11) 98,99,98
98 RINDEX = 99.11
C
C READ IN D SHELL PARAMETERS AND TABLES
C PERIPHERAL 1 IS THE CARD READER
C
READ (iread,21) (K(I),I=1,5)
READ (iread,22) ((IV(I,J),J=1,K(I)) I=1,5)
READ (iread,22) ((IL(I,J),J=1,K(I)) I=1,5)
READ (iread,22) ((IS(I,J),J=1,K(I)) I=1,5)
READ (iread,23) (ITAB1(I,1),I=1,K(2))
READ (iread,24) ((ITAB2(I,J),J=1,K(2)) I=1,K(3))
READ (1,24) ((ITAB3(I,J),J=1,K(3)) I=1,K(4))
READ (iread,25) ((ITAB4(I,J),J=1,K(4)) I=1,K(5))
READ (iread,23) (NORM1(I),I=1,K(2))
READ (iread,26) (NORM2(I),I=1,K(3))
READ (iread,25) (NORM3(I),I=1,K(4))
READ (iread,25) (NORM4(I),I=1,K(5))
C
C TEST IF N IS IN THE FIRST HALF OF SHELL
C
99 IF(N-6) 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-17) 41,11,11
41 IF(IV(N,J)-IVI) 101,42,101
42 IF(IL(N,J)-LI) 101,43,101
43 IF(IS(N,J)-ISI) 101,44,101
44 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) 45,30,45
30 IF(IVJ) 11,31,11
31 IF(LJ) 11,32,11
32 IF(ISJ-1) 11,1,11
45 J = 0
102 J = J+1
IF(J-17) 46,11,11
46 IF(IV(N-1,J)-IVJ) 102,47,102
47 IF(IL(N-1,J)-LJ) 102,48,102
48 IF(IS(N-1,J)-ISJ) 102,49,102
49 J2=J
GO TO 100
C
C SIMILAR SETTING OF J1 AND J2 IF N IS IN SECOND HALF OF SHELL
C
103 M = 10-N
IF(M) 36,33,36
33 IF(IVI) 11,34,11
34 IF(LI) 11,35,11
35 IF(ISI-1) 11,37,11
36 J = 0
104 J = J+1
IF(J-17) 50,11,11
50 IF(IV(M,J)-IVI) 104,51,104
51 IF(IL(M,J)-LI) 104,52,104
52 IF(IS(M,J)-ISI) 104,53,104
53 J1=J
37 J = 0
105 J = J+1
IF(J-17) 54,11,11
54 IF(IV(M+1,J)-IVJ) 105,55,105
55 IF(IL(M+1,J)-LJ) 105,56,105
56 IF(IS(M+1,J)-ISJ) 105,57,105
57 J2=J
C
C IDENTIFY THE F.P.C AS A UNIQUE ELEMENT OF ITABN(J1,J2)
C
100 GO TO (1,2,3,4,5,12,12,12,12,1),N
1 COEFP = 1.0
GO TO 10
2 COEFP = ITAB1(J1,J2)
IF(COEFP) 60,10,81
60 COEFP = - SQRT(-COEFP/NORM1(J1))
GO TO 10
81 COEFP = SQRT(COEFP/NORM1(J1))
GO TO 10
3 COEFP = ITAB2(J1,J2)
IF(COEFP) 61,10,82
61 COEFP = -SQRT(-COEFP/NORM2(J1))
GO TO 10
82 COEFP = SQRT(COEFP/NORM2(J1))
GO TO 10
4 COEFP = ITAB3(J1,J2)
IF(COEFP) 62,10,83
62 COEFP = -SQRT(-COEFP/NORM3(J1))
GO TO 10
83 COEFP = SQRT(COEFP/NORM3(J1))
GO TO 10
5 COEFP = ITAB4(J1,J2)
IF(COEFP) 63,10,84
63 COEFP = -SQRT(-COEFP/NORM4(J1))
GO TO 10
84 COEFP = SQRT(COEFP/NORM4(J1))
GO TO 10
C
C USE RECURRENCE RELATION EQUATION (19) OF RACAH FOR SECOND HALF OF
C SHELL
C
12 ISIGN = (-1)**((ISI+ISJ-7)/2 +LI +LJ)
FACTOR = SQRT(((11.0-N)*ISJ*(2*LJ+1.0))/(N*ISI*(2*LI+1.0)))
M1 =N-5
GO TO(6,7,8,9),M1
6 COEFP = ITAB4(J2,J1)
IF(COEFP) 64,10,85
64 COEFP = -SQRT(-COEFP/NORM4(J2))
GO TO 86
85 COEFP = SQRT(COEFP/NORM4(J2))
86 COEFP = COEFP*ISIGN*FACTOR
IF(MOD((IVJ-1)/2,2)) 87,10,87
87 COEFP = -COEFP
GO TO 10
7 COEFP = ITAB3(J2,J1)
IF(COEFP) 65,10,88
65 COEFP = -SQRT(-COEFP/NORM3(J2))
GO TO 89
88 COEFP = SQRT(COEFP/NORM3(J2))
89 COEFP = COEFP * ISIGN * FACTOR
GO TO 10
8 COEFP = ITAB2(J2,J1)
IF(COEFP) 66,10,90
66 COEFP = -SQRT(-COEFP/NORM2(J2))
GO TO 91
90 COEFP = SQRT(COEFP/NORM2(J2))
91 COEFP = COEFP * ISIGN * FACTOR
GO TO 10
9 COEFP = ITAB1(J2,J1)
IF(COEFP) 67,10,92
67 COEFP = -SQRT(-COEFP/NORM1(J2))
GO TO 93
92 COEFP = SQRT(COEFP/NORM1(J2))
93 COEFP = COEFP * ISIGN * FACTOR
GO TO 10
C
27 format(37h fail in coefp at 11 unallowded state )
11 write(iwrite,27)
pause
C
10 CONTINUE
RETURN
END
▶EOF◀