|
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: 19200 (0x4b00)
Types: TextFile
Names: »cpc4«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦this⟧ »cpc4«
c
c cpc4
c
c acrn a 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 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
integer n(10),iv(10),il(10),is(10)
common/inform/iread,iwrite,ipunch
common/inf/writef
c
c set input and output channels
zone writef(128,1,stderror)
call zassign(writef,7)
call open(writef,4,'outf',0)
call cfpddata
c
C
C INITIALIZE TEN SETS OF INPUT DATA
C
iwrite=7
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,////)
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
call exit
END
c
c----------------------------------------------------------------
c e x i t
c----------------------------------------------------------------
c
subroutine exit
common/inf/writef
zone writef(128,1,stderror)
4 format(/a3)
eof=25.shift.16+25.shift.8+25
write(writef,4) eof
call close(writef,.true.)
stop
return
end
c
c------------------------------------------------------------------------
c c f p d d a t a
c-------------------------------------------------------------------------
c
subroutine cfpddata
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
RETURN
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
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
11 continue
c 106 FORMAT(37H FAIL IN CFPD AT 11 UNALLOWED STATE)
c 11 WRITE(IWRITE,106)
coefp=9.9
10 CONTINUE
RETURN
END
▶EOF◀