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
|
SUBROUTINE MECIH(DIAG,CIMAT,NMOS,LAB)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INCLUDE 'SIZES'
DIMENSION DIAG(*),CIMAT(*)
C
C BUILD THE C.I. MATRIX 'CIMAT' IN PACKED CANONICAL FORM.
C
COMMON /SPQR / ISPQR(NMECI**2,NMECI),IS,I,K
COMMON /NALMAT/ NALPHA(NMECI**2)
COMMON /MICROS/ MICROA(NMECI,4*NMECI**2), MICROB(NMECI,4*NMECI**2)
C
IK=0
C
C OUTER LOOP TO FILL C.I. MATRIX.
DO 30 I=1,LAB
IS=2
C
C INNER LOOP.
DO 20 K=1,I
IK=IK+1
CIMAT(IK)=0.D0
IX=0
IY=0
DO 10 J=1,NMOS
IX=IX+ABS(MICROA(J,I)-MICROA(J,K))
10 IY=IY+ABS(MICROB(J,I)-MICROB(J,K))
C
C CHECK IF MATRIX ELEMENT HAS TO BE ZERO
C
IF(IX+IY.GT.4 .OR. NALPHA(I).NE.NALPHA(K)) GO TO 20
IF(IX+IY.EQ.4) THEN
IF(IX.EQ.0)THEN
CIMAT(IK)=BABBCD(MICROA(1,I),MICROB(1,I)
1 ,MICROA(1,K),MICROB(1,K),NMOS)
ELSE IF(IX.EQ.2) THEN
CIMAT(IK)=AABBCD(MICROA(1,I),MICROB(1,I)
1 ,MICROA(1,K),MICROB(1,K),NMOS)
ELSE
CIMAT(IK)=AABACD(MICROA(1,I),MICROB(1,I)
1 ,MICROA(1,K),MICROB(1,K),NMOS)
ENDIF
ELSE IF(IX.EQ.2) THEN
CIMAT(IK)=AABABC(MICROA(1,I),MICROB(1,I)
1 ,MICROA(1,K),NMOS)
ELSE IF(IY.EQ.2) THEN
CIMAT(IK)=BABBBC(MICROA(1,I),MICROB(1,I)
1 ,MICROB(1,K),NMOS)
ELSE
CIMAT(IK)=DIAG(I)
ENDIF
20 CONTINUE
30 ISPQR(I,1)=IS-1
RETURN
END
|
