-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathwghtd5gg.f90
130 lines (130 loc) · 4.21 KB
/
wghtd5gg.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
!***********************************************************************
! *
SUBROUTINE WGHTD5GG (iatjpo, iaspar, Min_state, Max_state)
! *
! Print the weights of the largest five CSF contributors to each *
! ASF. *
! *
! Call(s) to: ALLOC, DALLOC, ISPAR, ITJPO. *
! *
! Last updated: 02 Nov 1992 *
! *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90 4.3E 08:39:50 2/21/04
!...Modified by Charlotte Froese Fischer
! Gediminas Gaigalas 11/02/17
!-----------------------------------------------
! M o d u l e s
!-----------------------------------------------
USE vast_kind_param, ONLY: DOUBLE
USE memory_man
USE EIGV_C
USE JLABL_C, LABJ=>JLBR
USE ORB_C
USE PRNT_C
!-----------------------------------------------
! I n t e r f a c e B l o c k s
!-----------------------------------------------
use ispar_I
IMPLICIT NONE
!-----------------------------------------------
! D u m m y A r g u m e n t s
!-----------------------------------------------
INTEGER, INTENT(IN) :: iatjpo, iaspar, Min_state, Max_state
!-----------------------------------------------
! L o c a l V a r i a b l e s
!-----------------------------------------------
INTEGER, DIMENSION(5) :: ICONF
REAL(DOUBLE),dimension(5)::wght
INTEGER :: NELT, NVEX, IV, ICF, IFIRST, I, M, L, IP
integer, dimension(:), pointer :: NEXT;
REAL(DOUBLE),dimension(:), pointer :: WT
!-----------------------------------------------
!
! Allocate storage for local arrays
!
CALL ALLOC (WT, NCF, 'WT', 'WGHTD5' )
CALL ALLOC (NEXT, NCF, 'NEXT', 'WGHTD5')
!
WRITE (29, 300)
!
IF (NCF < 5) NELT = NCF
!
NVEX = NVEC
!
! DO IV = 1, NVEX
DO IV = Min_state, Max_state
!
ICF = IVEC(IV)
!
! Set up linked list of weights
!
NEXT(1) = 0
WT(1) = EVEC(1 + (IV - 1)*NCF)**2
IFIRST = 1
L4: DO I = 2, NCF
M = IFIRST
L = 0
WT(I) = EVEC(I + (IV - 1)*NCF)**2
IF (WT(I) > WT(M)) THEN
IF (L /= 0) GO TO 3
NEXT(I) = IFIRST
IFIRST = I
CYCLE L4
ENDIF
L = M
M = NEXT(L)
DO WHILE(M /= 0)
IF (WT(I) > WT(M)) THEN
IF (L /= 0) GO TO 3
NEXT(I) = IFIRST
IFIRST = I
CYCLE L4
ENDIF
L = M
M = NEXT(L)
END DO
3 CONTINUE
NEXT(I) = NEXT(L)
NEXT(L) = I
END DO L4
!
! Print first five elements of list.
!
M = IFIRST
I = 0
!GG IF (ITJPO(M)==IATJPO(IV) .AND. ISPAR(M)==IASPAR(IV)) THEN
I = I + 1
WGHT(I) = WT(M)
ICONF(I) = M
!GG ENDIF
M = NEXT(M)
DO WHILE(M/=0 .AND. I<5)
!GG IF (ITJPO(M)==IATJPO(IV) .AND. ISPAR(M)==IASPAR(IV)) THEN
I = I + 1
WGHT(I) = WT(M)
ICONF(I) = M
!GG ENDIF
M = NEXT(M)
END DO
!GG IP = (IASPAR(IV) + 3)/2
IP = (ISPAR(ICONF(1)) + 3 ) / 2
NELT = MIN(I,5)
WRITE (29, 301) ICF, JLBL(IATJPO), JLBP(IP), (WGHT(I),I=1,NELT)
WRITE (29, 302) (ICONF(I),I=1,NELT)
END DO
!
! Deallocate storage for local arrays
!
CALL DALLOC (WT, 'WT', 'WGHTD5')
CALL DALLOC (NEXT, 'NEXT', 'WGHTD5')
!
RETURN
!
300 FORMAT(/,'Weights of major contributors to ASF:'/,/,&
'Level J Parity CSF contributions'/)
301 FORMAT(I3,2X,2A4,5(D12.4))
302 FORMAT(13X,5I12)
RETURN
!
END SUBROUTINE WGHTD5GG