|
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: 76800 (0x12c00)
Types: TextFile
Names: »dlist«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦this⟧ »dlist«
4427 118 DO 119 I=1,J6CP
4428 I1=J6P(I)
4429 STOR1 = STOR1*SQRT(FLOAT(JSUM2(I1)))
4430 119 CONTINUE
4431 117 IF(J7CP) 120,120,121
4432 121 DO 122 I=1,J7CP
4433 I1=J7P(I)
4434 IX2 = IX2 + JSUM2(I1) - 1
4435 122 CONTINUE
4436 120 IF(J8CP) 123,123,124
4437 124 DO 125 I=1,J8CP
4438 I1=J8P(I)
4439 IX2 = IX2 - JSUM2(I1) + 1
4440 125 CONTINUE
4441 123 IX2 = IX2/2
4442 C
4443 C ADD TERM INTO STOR AND RESET STOR1 TO 1 READY FOR NEXT TERM
4444 C
4445 IF (MOD(IX2,2) .EQ. 1) STOR1 = -STOR1
4446 STOR = STOR + STOR1
4447 STOR1=ONE
4448 GO TO 83
4449 C
4450 C NO SUMMATIONS. CHECK THAT THERE ARE NO INCONSISTENCIES. THEN
4451 C MULTIPLY BY (-1) FACTOR AND EXIT
4452 C
4453 12 IF(J6CP+J7CP+J8CP) 309,309,310
4454 310 WRITE(IWRITE,311)
4455 CALL EXIT
4456 309 IX2 = IASTOR/2
4457 IF (MOD(IX2,2) .EQ. 1) RECUP = -RECUP
4458 RETURN
4459 END
4460 c
4461 c------------------------------------------------------------------
4462 c d r a c a h
4463 c------------------------------------------------------------------
4464 c
4465 SUBROUTINE DRACAH (J1,J2,L2,L1,J3,L3,D6J)
4466 C THIS SUBROUTINE WAS ORIGINALLY WRITTEN BY G.BESSIS TO COMPUTE
4467 C 6-J SYMBOLS. THIS VERSION HAS BEEN SLIGHTLY MODIFIED TO GIVE
4468 C RACAH COEFFICENTS WITH A CALL COMPATIBLE WITH AAGD
4469 C ARGUMENTS ARE DOUBLE THE ACTUAL QUANTUM NUMBERS
4470 DIMENSION KC(11),NA(31),MC(23),NC(7),NB(31)
4471 COMMON/INFORM/IREAD,IWRITE,IPUNCH
4472 common/const/zero,tenth,half,one,two,three,four,seven,eleven,eps
4473 kc(1)=2
4474 kc(2)=3
4475 kc(3)=5
4476 kc(4)=7
4477 kc(5)=11
4478 kc(6)=13
4479 kc(7)=17
4480 kc(8)=19
4481 kc(9)=23
4482 kc(10)=29
4483 kc(11)=31
4484 D6J=ZERO
4485 IF(IABS(L1-J2).GT.L3.OR.IABS(J2-L3).GT.L1.OR.IABS(L1-L3).GT.J2) GO
4486 1TO 99
4487 IF(IABS(J1-J2).GT.J3.OR.IABS(J2-J3).GT.J1.OR.IABS(J1-J3).GT.J2) GO
4488 1TO 99
4489 IF(IABS(L1-L2).GT.J3.OR.IABS(L2-J3).GT.L1.OR.IABS(L1-J3).GT.L2) GO
4490 1TO 99
4491 IF(IABS(J1-L2).GT.L3.OR.IABS(L2-L3).GT.J1.OR.IABS(J1-L3).GT.L2) GO
4492 1TO 99
4493 DO 5 I=1,31
4494 5 NA(I)=0
4495 MC(1)=J1+J2-J3
4496 MC(2)=J1-J2+J3
4497 MC(3)=-J1+J2+J3
4498 MC(4)=J1+L2-L3
4499 MC(5)=J1-L2+L3
4500 MC(6)=-J1+L2+L3
4501 MC(7)=L1+J2-L3
4502 MC(8)=L1-J2+L3
4503 MC(9)=-L1+J2+L3
4504 MC(10)=L1+L2-J3
4505 MC(11)=L1-L2+J3
4506 MC(12)=-L1+L2+J3
4507 MC(13)=J1+J2+J3+2
4508 MC(14)=J1+L2+L3+2
4509 MC(15)=L1+J2+L3+2
4510 MC(16)=L1+L2+J3+2
4511 MC(17)=J1+J2+J3
4512 MC(18)=J1+L2+L3
4513 MC(19)=L1+J2+L3
4514 MC(20)=L1+L2+J3
4515 MC(21)=J1+J2+L1+L2
4516 MC(22)=J2+J3+L2+L3
4517 MC(23)=J3+J1+L3+L1
4518 DO 6 I=1,23
4519 IF (MOD(MC(I),2).NE.0) GO TO 98
4520 MC(I)=MC(I)/2
4521 IF(MC(I).LT.0) GO TO 99
4522 IF(MC(I).GT.31) GO TO 98
4523 6 CONTINUE
4524 DO 20 I=1,12
4525 N=MC(I)
4526 DO 15 J=1,N
4527 15 NA(J)=NA(J)+1
4528 20 CONTINUE
4529 DO 17 I=13,16
4530 N=MC(I)
4531 DO 16 J=1,N
4532 16 NA(J)=NA(J)-1
4533 17 CONTINUE
4534 DO 26 I=1,31
4535 26 NB(I)=NA(I)
4536 IZM=MIN0(MC(21),MC(22),MC(23))
4537 IZD=MAX0(MC(17),MC(18),MC(19),MC(20))
4538 ISIG=1
4539 IF (MOD(IZD,2).NE.0) ISIG=-ISIG
4540 DO 60 IZ=IZD,IZM
4541 NC(1)=IZ-MC(17)
4542 NC(2)=IZ-MC(18)
4543 NC(3)=IZ-MC(19)
4544 NC(4)=IZ-MC(20)
4545 NC(5)=MC(21)-IZ
4546 NC(6)=MC(22)-IZ
4547 NC(7)=MC(23)-IZ
4548 DO 28 I=1,31
4549 28 NA(I)=NB(I)
4550 N=IZ+1
4551 DO 29 I=1,N
4552 29 NA(I)=NA(I)+2
4553 DO 40 I=1,7
4554 N=NC(I)
4555 DO 35 J=1,N
4556 35 NA(J)=NA(J)-2
4557 40 CONTINUE
4558 NA(2)=NA(2)+2*NA(4)+NA(6)+3*NA(8)+NA(10)+2*NA(12)+NA(14)+4*NA(16)+
4559 1NA(18)+2*NA(20)+NA(22)+3*NA(24)+NA(26)+2*NA(28)+NA(30)
4560 NA(3)=NA(3)+NA(6)+2*NA(9)+NA(12)+NA(15)+2*NA(18)+NA(21)+NA(24)+3*N
4561 1A(27)+NA(30)
4562 NA(5)=NA(5)+NA(10)+NA(15)+NA(20)+2*NA(25)+NA(30)
4563 NA(7)=NA(7)+NA(14)+NA(21)+NA(28)
4564 NA(11)=NA(11)+NA(22)
4565 NA(13)=NA(13)+NA(26)
4566 DRA=ONE
4567 DAX=ONE
4568 DNR=ONE
4569 DO 50 K=1,11
4570 I=KC(K)
4571 N=NA(I)
4572 IF(N.EQ.0) GO TO 50
4573 IF(MOD(N,2)) 41,42,41
4574 41 N=N-1
4575 DRA=DRA*I
4576 42 N=N/2
4577 IF(N) 43,50,45
4578 43 N=-N
4579 DO 44 IN=1,N
4580 44 DNR=DNR*I
4581 GO TO 50
4582 45 DO 46 IN=1,N
4583 46 DAX=DAX*I
4584 50 CONTINUE
4585 DRA = SQRT(DRA)
4586 D6J=D6J+(DAX*DRA*ISIG)/DNR
4587 ISIG=-ISIG
4588 60 CONTINUE
4589 IF( MOD( (J1+J2+L1+L2)/2,2) .EQ. 0) GO TO 99
4590 D6J = -D6J
4591 GO TO 99
4592 98 WRITE (IWRITE,101) J1,J2,L1,L2,J3,L3
4593 101 FORMAT(44H FAILURE IN CALCULATING RACAH COEFFICIENT W(,3(I3,1H,),I
4594 13,1H$,I3,1H,,I3,1H))
4595 CALL EXIT
4596 99 RETURN
4597 END
4598 c
4599 c------------------------------------------------------------------------
4600 c c f p p
4601 c-------------------------------------------------------------------------
4602 c
4603 SUBROUTINE CFPP(N,LI,ISI,LJ,ISJ,COEFP)
4604 C
4605 C THIS SUBROUTINE EVALUATES THE COEFFICIENTS OF FRACTIONAL PARENTAGE
4606 C FOR EQUIVALENT P SHELL ELECTRONS FROM TABLES GIVEN IN J.C.SLATER
4607 C QUANTUM THEORY OF ATOMIC STRUCTURE,VOLUME2,P350(1960)
4608 C IN THE SUBROUTINE LIST N,THE NO. OF ELECTRONS,L THE ANGULAR
4609 C MOMENTUM QUANTUM NO.,(2S+1) THE SPIN QUANTUM NO. OF BOTH THE STATE
4610 C IN QUESTION AND ITS PARENT STATE ARE INPUT PARAMETERS.THE RESULT
4611 C IS OUTPUT AS COEFP
4612 C
4613 integer IL(3,3),IS(3,3),ITAB1(3,1),ITAB2(3,3),NORM1(3),NORM2(3)
4614 common/inform/iread,iwrite,ipunch
4615 C
4616 C
4617 C SET UP P SHELL PARAMETERS AND TABLES
4618 C
4619 il(1,1)=1
4620 il(2,1)=1
4621 il(2,2)=2
4622 il(2,3)=0
4623 il(3,1)=0
4624 il(3,2)=2
4625 il(3,3)=1
4626 is(1,1)=2
4627 is(2,1)=3
4628 is(2,2)=1
4629 is(2,3)=1
4630 is(3,1)=4
4631 is(3,2)=2
4632 is(3,3)=2
4633 itab1(1,1)=1
4634 itab1(2,1)=1
4635 itab1(3,1)=1
4636 itab2(1,1)=1
4637 itab2(1,2)=0
4638 itab2(1,3)=0
4639 itab2(2,1)=1
4640 itab2(2,2)=-1
4641 itab2(2,3)=0
4642 itab2(3,1)=-9
4643 itab2(3,2)=-5
4644 itab2(3,3)=4
4645 norm1(1)=1
4646 norm1(2)=1
4647 norm1(3)=1
4648 norm2(1)=1
4649 norm2(2)=2
4650 norm2(3)=18
4651 C
4652 C TEST IF N IS IN THE FIRST HALF OF SHELL
4653 C
4654 IF(N-4) 40,103,103
4655 C
4656 C TEST IF STATE IN QUESTION IS ALLOWED
4657 C IF IT IS, IDENTIFY THE ROW OF THE TABLE BY J1
4658 C
4659 40 J = 0
4660 101 J = J+1
4661 IF(J-4) 41,8,8
4662 41 IF(IL(N,J)-LI) 101,42,101
4663 42 IF(IS(N,J)-ISI) 101,43,101
4664 43 J1 = J
4665 C
4666 C TEST IF PARENT STATE IS ALLOWED
4667 C IF IT IS, IDENTIFY THE COLUMN OF THE TABLE BY J2
4668 C
4669 IF(N-1) 44,70,44
4670 70 IF(LJ) 8,71,8
4671 71 IF(ISJ-1) 8,1,8
4672 44 J = 0
4673 102 J = J+1
4674 IF(J-4) 45,8,8
4675 45 IF(IL(N-1,J)-LJ) 102,46,102
4676 46 IF(IS(N-1,J)-ISJ) 102,47,102
4677 47 J2 = J
4678 GO TO 100
4679 C
4680 C SIMILAR SETTING OF J1 AND J2 IF N IS IN SECOND HALF OF SHELL
4681 C
4682 103 M =6-N
4683 IF(M) 72,73,72
4684 73 IF(LI) 8,74,8
4685 74 IF(ISI-1) 8,75,8
4686 72 J = 0
4687 104 J = J+1
4688 IF(J-4) 48,8,8
4689 48 IF(IL(M,J)-LI) 104,49,104
4690 49 IF(IS(M,J)-ISI) 104,50,104
4691 50 J1 = J
4692 75 J = 0
4693 105 J = J+1
4694 IF(J-4) 51,8,8
4695 51 IF(IL(M+1,J)-LJ) 105,52,105
4696 52 IF(IS(M+1,J)-ISJ) 105,53,105
4697 53 J2 = J
4698 C
4699 C
4700 C IDENTIFY THE F.P.C AS A UNIQUE ELEMENT OF ITABN(J1,J2)
4701 C
4702 100 GO TO (1,2,3,4,4,1),N
4703 1 COEFP = 1.0
4704 GO TO 10
4705 2 COEFP = ITAB1(J1,J2)
4706 IF(COEFP) 54,10,31
4707 54 COEFP = -SQRT(-COEFP/NORM1(J1))
4708 GO TO 10
4709 31 COEFP = SQRT(COEFP/NORM1(J1))
4710 GO TO 10
4711 3 COEFP = ITAB2(J1,J2)
4712 IF(COEFP) 55,10,32
4713 55 COEFP = -SQRT(-COEFP/NORM2(J1))
4714 GO TO 10
4715 32 COEFP =SQRT(COEFP/NORM2(J1))
4716 GO TO 10
4717 C
4718 C USE RECURRENCE RELATION EQUATION (19) OF RACAH FOR SECOND HALF OF
4719 C SHELL
4720 C
4721 4 ISIGN = (-1)**((ISI+ISJ-5)/2+LI+LJ)
4722 FACTOR = ((7.0-N)*ISJ*(2*LJ+1.0))/(N*ISI*(2*LI+1.0))
4723 IF(N-5) 56,5,8
4724 56 COEFP = ITAB2(J2,J1)
4725 IF(COEFP) 57,10,33
4726 57 COEFP = -SQRT(-COEFP/NORM2(J2))
4727 GO TO 34
4728 33 COEFP = SQRT(COEFP/NORM2(J2))
4729 34 COEFP = COEFP * ISIGN * SQRT(FACTOR)
4730 IF(LJ-1) 35,10,35
4731 35 COEFP = -COEFP
4732 GO TO 10
4733 5 COEFP = ITAB1(J2,J1)
4734 IF(COEFP) 58,10,36
4735 58 COEFP = -SQRT(-COEFP/NORM1(J2))
4736 GO TO 37
4737 36 COEFP = SQRT(COEFP/NORM1(J2))
4738 37 COEFP = COEFP * ISIGN * SQRT(FACTOR)
4739 GO TO 10
4740 C
4741 8 continue
4742 c16 format(37h fail in coefp at 8 unallowed state)
4743 c write(iwrite,16)
4744 coefp=9.9
4745 10 CONTINUE
4746 RETURN
4747 END
4748 c
4749 c------------------------------------------------------------------------
4750 c c f p d d a t a
4751 c-------------------------------------------------------------------------
4752 c
4753 subroutine cfpddata
4754 C
4755 COMMON/FRPAR2/I(719)
4756 C
4757 C BLOCK DATA FOR CFPD SUBROUTINE
4758 C
4759 DATA I( 1),I( 2),I( 3),I( 4),I( 5),I( 6),I( 7),I( 8),
4760 1 I( 9),I( 10),I( 11),I( 12),I( 13),I( 14),I( 15),I( 16),
4761 1 I( 17),I( 18),I( 19),I( 20),I( 21),I( 22),I( 23),I( 24),
4762 2 I( 25),I( 26),I( 27),I( 28),I( 29),I( 30),I( 31),I( 32),
4763 3 I( 33),I( 34),I( 35),I( 36),I( 37),I( 38),I( 39),I( 40),
4764 4 I( 41),I( 42),I( 43),I( 44),I( 45),I( 46),I( 47),I( 48),
4765 5 I( 49),I( 50),I( 51),I( 52),I( 53),I( 54),I( 55),I( 56),
4766 6 I( 57),I( 58),I( 59),I( 60),I( 61),I( 62),I( 63),I( 64),
4767 7 I( 65),I( 66),I( 67),I( 68),I( 69),I( 70),I( 71),I( 72),
4768 8 I( 73),I( 74),I( 75),I( 76),I( 77),I( 78),I( 79),I( 80)/
4769 1 1, 5, 8, 16, 16, 1, 2, 3,
4770 1 4, 5, 0, 2, 3, 4, 5, 0,
4771 1 2, 3, 4, 3, 0, 2, 3, 2,
4772 2 5, 0, 0, 3, 4, 3, 0, 0,
4773 3 1, 4, 5, 0, 0, 3, 2, 3,
4774 4 0, 0, 3, 4, 3, 0, 0, 0,
4775 5 4, 5, 0, 0, 0, 2, 3, 0,
4776 6 0, 0, 4, 5, 0, 0, 0, 4,
4777 7 1, 0, 0, 0, 2, 3, 0, 0,
4778 8 0, 4, 5, 0, 0, 0, 0, 3/
4779 DATA I( 81),I( 82),I( 83),I( 84),I( 85),I( 86),I( 87),I( 88),
4780 1 I( 89),I( 90),I( 91),I( 92),I( 93),I( 94),I( 95),I( 96),
4781 1 I( 97),I( 98),I( 99),I(100),I(101),I(102),I(103),I(104),
4782 2 I(105),I(106),I(107),I(108),I(109),I(110),I(111),I(112),
4783 3 I(113),I(114),I(115),I(116),I(117),I(118),I(119),I(120),
4784 4 I(121),I(122),I(123),I(124),I(125),I(126),I(127),I(128),
4785 5 I(129),I(130),I(131),I(132),I(133),I(134),I(135),I(136),
4786 6 I(137),I(138),I(139),I(140),I(141),I(142),I(143),I(144),
4787 7 I(145)/
4788 1 0, 0, 0, 4, 5, 2, 3, 3,
4789 1 2, 0, 0, 1, 1, 5, 4, 0,
4790 1 4, 5, 4, 3, 0, 2, 4, 3,
4791 2 2, 0, 0, 3, 3, 1, 0, 0,
4792 3 2, 2, 6, 0, 0, 2, 1, 5,
4793 4 0, 0, 1, 1, 4, 0, 0, 0,
4794 5 6, 4, 0, 0, 0, 4, 3, 0,
4795 6 0, 0, 4, 3, 0, 0, 0, 3,
4796 7 2/
4797 DATA I(146),I(147),I(148),I(149),I(150),I(151),I(152),I(153),
4798 1 I(154),I(155),I(156),I(157),I(158),I(159),I(160),I(161),
4799 1 I(162),I(163),I(164),I(165),I(166),I(167),I(168),I(169),
4800 2 I(170),I(171),I(172),I(173),I(174),I(175),I(176),I(177),
4801 3 I(178),I(179),I(180),I(181),I(182),I(183),I(184),I(185),
4802 4 I(186),I(187),I(188),I(189),I(190),I(191),I(192),I(193),
4803 5 I(194),I(195),I(196),I(197),I(198),I(199),I(200),I(201),
4804 6 I(202),I(203),I(204),I(205),I(206),I(207),I(208),I(209),
4805 7 I(210),I(211),I(212),I(213),I(214),I(215),I(216),I(217),
4806 8 I(218),I(219),I(220),I(221),I(222),I(223),I(224),I(225)/
4807 1 0, 0, 0, 2, 2, 0, 0, 0,
4808 1 2, 2, 0, 0, 0, 0, 1, 0,
4809 1 0, 0, 0, 0, 2, 3, 4, 5,
4810 2 6, 0, 3, 4, 3, 4, 0, 1,
4811 3 2, 3, 4, 0, 1, 2, 3, 4,
4812 4 0, 1, 2, 3, 4, 0, 0, 2,
4813 5 3, 2, 0, 0, 2, 3, 2, 0,
4814 6 0, 2, 3, 2, 0, 0, 0, 1,
4815 7 2, 0, 0, 0, 1, 2, 0, 0,
4816 8 0, 1, 2, 0, 0, 0, 1, 2/
4817 DATA I(226),I(227),I(228),I(229),I(230),I(231),I(232),I(233),
4818 1 I(234),I(235),I(236),I(237),I(238),I(239),I(240),I(241),
4819 1 I(242),I(243),I(244),I(245),I(246),I(247),I(248),I(249),
4820 2 I(250),I(251),I(252),I(253),I(254),I(255),I(256),I(257),
4821 3 I(258),I(259),I(260),I(261),I(262),I(263),I(264),I(265),
4822 4 I(266),I(267),I(268),I(269),I(270),I(271),I(272),I(273),
4823 5 I(274),I(275),I(276),I(277),I(278),I(279),I(280),I(281),
4824 6 I(282),I(283),I(284),I(285),I(286),I(287),I(288),I(289),
4825 7 I(290)/
4826 1 0, 0, 0, 1, 2, 0, 0, 0,
4827 1 1, 2, 0, 0, 0, 1, 2, 0,
4828 1 0, 0, 1, 2, 1, 1, 1, 1,
4829 2 1, 4, -7, -1, 21, 7, -21, 21,
4830 3 -8, -1, -8, 0, 0, 28, -9, -49,
4831 4 7, 0, 0, 1, 11, -25, -9, -25,
4832 5 0, 0, 0, 0, -10, -10, -5, 45,
4833 6 15, 0, 0, 0, 0, 0, 16, 0,
4834 7 0/
4835 DATA I(291),I(292),I(293),I(294),I(295),I(296),I(297),I(298),
4836 1 I(299),I(300),I(301),I(302),I(303),I(304),I(305),I(306),
4837 1 I(307),I(308),I(309),I(310),I(311),I(312),I(313),I(314),
4838 2 I(315),I(316),I(317),I(318),I(319),I(320),I(321),I(322),
4839 3 I(323),I(324),I(325),I(326),I(327),I(328),I(329),I(330),
4840 4 I(331),I(332),I(333),I(334),I(335),I(336),I(337),I(338),
4841 5 I(339),I(340),I(341),I(342),I(343),I(344),I(345),I(346),
4842 6 I(347),I(348),I(349),I(350),I(351),I(352),I(353),I(354),
4843 7 I(355),I(356),I(357),I(358),I(359),I(360),I(361),I(362),
4844 8 I(363),I(364),I(365),I(366),I(367),I(368),I(369),I(370)/
4845 1 7, 20, -560, 224, -112, -21, -56, 16,
4846 1 0, 0, 0, 0, 0, 0, 0, 0,
4847 1 3, 0, 0, -56, -448, 49, -64, -14,
4848 2 0, 0, 0, 0, 0, 0, 0, 0,
4849 3 0, 26, 308, 110, 220, 0, 0, 0,
4850 4 7, -154, -28, -132, 0, 0, 0, 0,
4851 5 0, -9, 297, 90, -405, 45, 0, 0,
4852 6 3, 66, -507, -3, -60, 15, 0, 0,
4853 7 0, 5, 315, -14, -175, -21, -56, -25,
4854 8 0, 70, 385, -105, 28, 63, 0, 0/
4855 DATA I(371),I(372),I(373),I(374),I(375),I(376),I(377),I(378),
4856 1 I(379),I(380),I(381),I(382),I(383),I(384),I(385),I(386),
4857 1 I(387),I(388),I(389),I(390),I(391),I(392),I(393),I(394),
4858 2 I(395),I(396),I(397),I(398),I(399),I(400),I(401),I(402),
4859 3 I(403),I(404),I(405),I(406),I(407),I(408),I(409),I(410),
4860 4 I(411),I(412),I(413),I(414),I(415),I(416),I(417),I(418),
4861 5 I(419),I(420),I(421),I(422),I(423),I(424),I(425),I(426),
4862 6 I(427),I(428),I(429),I(430),I(431),I(432),I(433),I(434),
4863 7 I(435)/
4864 1 0, 0, 0, 315, 0, 0, 135, 0,
4865 1 0, 189, 0, 0, 105, 0, 1, 0,
4866 1 0, 0, 200, 15, 120, 60, -35, 10,
4867 2 0, -25, 88, 200, 45, 20, 0, 1,
4868 3 0, 0, 0, 16, -200, -14, -14, 25,
4869 4 0, 0, 0, 120, -42, 42, 0, 0,
4870 5 1, -105, -175, -175, -75, 0, 0, 0,
4871 6 0, 0, 0, 0, 0, 0, 0, 0,
4872 7 0/
4873 DATA I(436),I(437),I(438),I(439),I(440),I(441),I(442),I(443),
4874 1 I(444),I(445),I(446),I(447),I(448),I(449),I(450),I(451),
4875 1 I(452),I(453),I(454),I(455),I(456),I(457),I(458),I(459),
4876 2 I(460),I(461),I(462),I(463),I(464),I(465),I(466),I(467),
4877 3 I(468),I(469),I(470),I(471),I(472),I(473),I(474),I(475),
4878 4 I(476),I(477),I(478),I(479),I(480),I(481),I(482),I(483),
4879 5 I(484),I(485),I(486),I(487),I(488),I(489),I(490),I(491),
4880 6 I(492),I(493),I(494),I(495),I(496),I(497),I(498),I(499),
4881 7 I(500),I(501),I(502),I(503),I(504),I(505),I(506),I(507),
4882 8 I(508),I(509),I(510),I(511),I(512),I(513),I(514),I(515)/
4883 1 154, -110, 0, 0, 231, 286, 924, -308,
4884 1 220, -396, 0, 0, 0, 0, 0, 0,
4885 1 -66, -90, 180, 0, 99, -99, 891,-5577,
4886 2 -405, -9, 0, 45, 45, 0, 0, 0,
4887 3 0, 224, 0, -56, 0, -220, 1680, 0,
4888 4 112, 0, -21, 21, 0, -16, 0, 0,
4889 5 -70, 14, -84, 56, 0, 55, 945, 4235,
4890 6 -175, -315, 0, -21, 189, -25, 0, 0,
4891 7 25, -15, -135, 35, 0, 0, 600, 968,
4892 8 120, 600, 0, 60, 60, 10, 3, 0/
4893 DATA I(516),I(517),I(518),I(519),I(520),I(521),I(522),I(523),
4894 1 I(524),I(525),I(526),I(527),I(528),I(529),I(530),I(531),
4895 1 I(532),I(533),I(534),I(535),I(536),I(537),I(538),I(539),
4896 2 I(540),I(541),I(542),I(543),I(544),I(545),I(546),I(547),
4897 3 I(548),I(549),I(550),I(551),I(552),I(553),I(554),I(555),
4898 4 I(556),I(557),I(558),I(559),I(560),I(561),I(562),I(563),
4899 5 I(564),I(565),I(566),I(567),I(568),I(569),I(570),I(571),
4900 6 I(572),I(573),I(574),I(575),I(576),I(577),I(578),I(579),
4901 7 I(580)/
4902 1 0, -56, 0, -64, 0, 0, 0, 0,
4903 1 448, 0, -9, -49, 0, 14, 0, 0,
4904 1 0, -16, 126, 14, 0, 0, 0, 0,
4905 2 -200, 360, 0, -14, 126, 25, 0, 0,
4906 3 0, 0, 0, 0, -175, 182, -728,-2184,
4907 4 0, 0, 0, 0, 0, 0, 0, 0,
4908 5 0, 0, 0, 0, 0, 220, 880, 0,
4909 6 -400, 0, -9, -25, 0, 0, 0, 0,
4910 7 0/
4911 DATA I(581),I(582),I(583),I(584),I(585),I(586),I(587),I(588),
4912 1 I(589),I(590),I(591),I(592),I(593),I(594),I(595),I(596),
4913 1 I(597),I(598),I(599),I(600),I(601),I(602),I(603),I(604),
4914 2 I(605),I(606),I(607),I(608),I(609),I(610),I(611),I(612),
4915 3 I(613),I(614),I(615),I(616),I(617),I(618),I(619),I(620),
4916 4 I(621),I(622),I(623),I(624),I(625),I(626),I(627),I(628),
4917 5 I(629),I(630),I(631),I(632),I(633),I(634),I(635),I(636),
4918 6 I(637),I(638),I(639),I(640),I(641),I(642),I(643),I(644),
4919 7 I(645),I(646),I(647),I(648),I(649),I(650),I(651),I(652),
4920 8 I(653),I(654),I(655),I(656),I(657),I(658),I(659),I(660)/
4921 1 0, 0, 0, -45, -5, 845,-1215, 275,
4922 1 495, 0, -11, 99, 0, 0, 0, 0,
4923 1 0, 0, 0, 0, 33, -7,-2541, 105,
4924 2 -525, 0, 35, 35, -15, 0, 0, 0,
4925 3 0, 0, 0, 0, 0, -800, 0, -160,
4926 4 0, -5, 45, 0, 30, 0, 0, 0,
4927 5 0, 0, 0, 0, 0, -100, 1452, 180,
4928 6 -100, 0, -10, 90, 15, -2, 0, 0,
4929 7 0, 0, 0, 0, 0, 0, 0, 0,
4930 8 0, 6, 0, 0, 0, 0, 0, 0/
4931 DATA I(661),I(662),I(663),I(664),I(665),I(666),I(667),I(668),
4932 1 I(669),I(670),I(671),I(672),I(673),I(674),I(675),I(676),
4933 1 I(677),I(678),I(679),I(680),I(681),I(682),I(683),I(684),
4934 2 I(685),I(686),I(687),I(688),I(689),I(690),I(691),I(692),
4935 3 I(693),I(694),I(695),I(696),I(697),I(698),I(699),I(700),
4936 4 I(701),I(702),I(703),I(704),I(705),I(706),I(707),I(708),
4937 5 I(709),I(710),I(711),I(712),I(713),I(714),I(715),I(716),
4938 6 I(717),I(718),I(719)/
4939 1 0, 0, 0, 0, 0, 0, 0, 0,
4940 1 0, 0, -14, -56, 0, 0, 1, 1,
4941 1 1, 1, 1, 5, 15, 2, 42, 70,
4942 2 60, 140, 30, 10, 60, 1680, 840, 1680,
4943 3 210, 360, 90, 10, 504, 1008, 560, 280,
4944 4 140, 1, 1, 1, 420, 700, 700, 300,
4945 5 550, 1100, 8400,18480, 2800, 2800, 50, 350,
4946 6 700, 150, 5/
4947 C
4948 END
4949 c
4950 c----------------------------------------------------------------------
4951 c cfpd
4952 c-----------------------------------------------------------------------
4953 c
4954 SUBROUTINE CFPD(N,IVI,LI,ISI,IVJ,LJ,ISJ,COEFP)
4955 C
4956 C
4957 C THIS SUBROUTINE EVALUATES THE COEFFICIENTS OF FRACTIONAL PARENTAGE
4958 C FOR EQUIVALENT D SHELL ELECTRONS FROM TABLES GIVEN IN J.C.SLATER
4959 C QUANTUM THEORY OF ATOMIC STRUCTURE,VOLUME2,P350(1960)
4960 C IN THE SUBROUTINE LIST N,THE NO.OF ELECTRONS,V THE SENIORITY QUAN
4961 C TUM NO.,L THE ANGULAR MOMENTUM QUANTUM NO.,(2S+1) THE SPIN QUANTUM
4962 C NO. OF BOTH THE STATE IN QUESTION AND ITS PARENT STATE ARE INPUT
4963 C PARAMETERS THE RESULT IS OUTPUT AS COEFP
4964 C
4965 COMMON/FRPAR2/K(5),IV(5,16),IL(5,16),IS(5,16),ITAB1(5,1),ITAB2(8,5
4966 1 ),ITAB3(16,8),ITAB4(16,16),NORM1(5),NORM2(8),NORM3(16),NORM4(16)
4967 COMMON/INFORM/IREAD,IWRITE,IPUNCH
4968 C
4969 C
4970 C TEST IF N IS IN THE FIRST HALF OF SHELL
4971 C
4972 IF(N-6) 40,103,103
4973 C
4974 C TEST IF STATE IN QUESTION IS ALLOWED
4975 C IF IT IS, IDENTIFY THE ROW OF THE TABLE BY J1
4976 C
4977 40 J = 0
4978 101 J = J+1
4979 IF(J-17) 41,11,11
4980 41 IF(IV(N,J)-IVI) 101,42,101
4981 42 IF(IL(N,J)-LI) 101,43,101
4982 43 IF(IS(N,J)-ISI) 101,44,101
4983 44 J1=J
4984 C
4985 C TEST IF PARENT STATE IS ALLOWED
4986 C IF IT IS, IDENTIFY THE COLUMN OF THE TABLE BY J2
4987 C
4988 IF(N-1) 45,30,45
4989 30 IF(IVJ) 11,31,11
4990 31 IF(LJ) 11,32,11
4991 32 IF(ISJ-1) 11,1,11
4992 45 J = 0
4993 102 J = J+1
4994 IF(J-17) 46,11,11
4995 46 IF(IV(N-1,J)-IVJ) 102,47,102
4996 47 IF(IL(N-1,J)-LJ) 102,48,102
4997 48 IF(IS(N-1,J)-ISJ) 102,49,102
4998 49 J2=J
4999 GO TO 100
5000 C
5001 C SIMILAR SETTING OF J1 AND J2 IF N IS IN SECOND HALF OF SHELL
5002 C
5003 103 M = 10-N
5004 IF(M) 36,33,36
5005 33 IF(IVI) 11,34,11
5006 34 IF(LI) 11,35,11
5007 35 IF(ISI-1) 11,37,11
5008 36 J = 0
5009 104 J = J+1
5010 IF(J-17) 50,11,11
5011 50 IF(IV(M,J)-IVI) 104,51,104
5012 51 IF(IL(M,J)-LI) 104,52,104
5013 52 IF(IS(M,J)-ISI) 104,53,104
5014 53 J1=J
5015 37 J = 0
5016 105 J = J+1
5017 IF(J-17) 54,11,11
5018 54 IF(IV(M+1,J)-IVJ) 105,55,105
5019 55 IF(IL(M+1,J)-LJ) 105,56,105
5020 56 IF(IS(M+1,J)-ISJ) 105,57,105
5021 57 J2=J
5022 C
5023 C IDENTIFY THE F.P.C AS A UNIQUE ELEMENT OF ITABN(J1,J2)
5024 C
5025 100 GO TO (1,2,3,4,5,12,12,12,12,1),N
5026 1 COEFP = 1.0
5027 GO TO 10
5028 2 COEFP = ITAB1(J1,J2)
5029 IF(COEFP) 60,10,81
5030 60 COEFP = - SQRT(-COEFP/NORM1(J1))
5031 GO TO 10
5032 81 COEFP = SQRT(COEFP/NORM1(J1))
5033 GO TO 10
5034 3 COEFP = ITAB2(J1,J2)
5035 IF(COEFP) 61,10,82
5036 61 COEFP = -SQRT(-COEFP/NORM2(J1))
5037 GO TO 10
5038 82 COEFP = SQRT(COEFP/NORM2(J1))
5039 GO TO 10
5040 4 COEFP = ITAB3(J1,J2)
5041 IF(COEFP) 62,10,83
5042 62 COEFP = -SQRT(-COEFP/NORM3(J1))
5043 GO TO 10
5044 83 COEFP = SQRT(COEFP/NORM3(J1))
5045 GO TO 10
5046 5 COEFP = ITAB4(J1,J2)
5047 IF(COEFP) 63,10,84
5048 63 COEFP = -SQRT(-COEFP/NORM4(J1))
5049 GO TO 10
5050 84 COEFP = SQRT(COEFP/NORM4(J1))
5051 GO TO 10
5052 C
5053 C USE RECURRENCE RELATION EQUATION (19) OF RACAH FOR SECOND HALF OF
5054 C SHELL
5055 C
5056 12 ISIGN = (-1)**((ISI+ISJ-7)/2 +LI +LJ)
5057 FACTOR = SQRT(((11.0-N)*ISJ*(2*LJ+1.0))/(N*ISI*(2*LI+1.0)))
5058 M1 =N-5
5059 GO TO(6,7,8,9),M1
5060 6 COEFP = ITAB4(J2,J1)
5061 IF(COEFP) 64,10,85
5062 64 COEFP = -SQRT(-COEFP/NORM4(J2))
5063 GO TO 86
5064 85 COEFP = SQRT(COEFP/NORM4(J2))
5065 86 COEFP = COEFP*ISIGN*FACTOR
5066 IF(MOD((IVJ-1)/2,2)) 87,10,87
5067 87 COEFP = -COEFP
5068 GO TO 10
5069 7 COEFP = ITAB3(J2,J1)
5070 IF(COEFP) 65,10,88
5071 65 COEFP = -SQRT(-COEFP/NORM3(J2))
5072 GO TO 89
5073 88 COEFP = SQRT(COEFP/NORM3(J2))
5074 89 COEFP = COEFP * ISIGN * FACTOR
5075 GO TO 10
5076 8 COEFP = ITAB2(J2,J1)
5077 IF(COEFP) 66,10,90
5078 66 COEFP = -SQRT(-COEFP/NORM2(J2))
5079 GO TO 91
5080 90 COEFP = SQRT(COEFP/NORM2(J2))
5081 91 COEFP = COEFP * ISIGN * FACTOR
5082 GO TO 10
5083 9 COEFP = ITAB1(J2,J1)
5084 IF(COEFP) 67,10,92
5085 67 COEFP = -SQRT(-COEFP/NORM1(J2))
5086 GO TO 93
5087 92 COEFP = SQRT(COEFP/NORM1(J2))
5088 93 COEFP = COEFP * ISIGN * FACTOR
5089 GO TO 10
5090 C
5091 11 continue
5092 c 106 FORMAT(37H FAIL IN CFPD AT 11 UNALLOWED STATE)
5093 c 11 WRITE(IWRITE,106)
5094 coefp=9.9
5095 10 CONTINUE
5096 RETURN
5097 END
\f
programunit cfgout page 1
error messages
6. line 431 . 1 label
line 431 . 1 statement structure
line 443 . 2 label \f
programunit vijout page 1
error messages
line 641 . 0 label syntax 76
line 646 . 2 label \f
programunit cfp page 1
error messages
line 1527 . 0 statement structure
line 1539 . 3 label \f
programunit gensum page 1
error messages
line 3916 . 1 label not referred
line 4454 . 3 statement structure
***fortran sorry 163
***break 0 147910
▶EOF◀