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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
C Copyright (c) 2003-2010 University of Florida
C
C This program is free software; you can redistribute it and/or modify
C it under the terms of the GNU General Public License as published by
C the Free Software Foundation; either version 2 of the License, or
C (at your option) any later version.
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C The GNU General Public License is included in this distribution
C in the file COPYRIGHT.
c RECORDS
c get DOIT//'ORDR'
c get DOIT//'NORB'
c get DOIT//'NIRX'
c get 'COMPORDR'
c get 'COMPNORB'
c get 'COMPNIRX'
#include "flags.h"
subroutine init_fd(doit,natom,icore,icrsiz,nener,bprint)
implicit none
character*4 doit
integer natom, icore(*), icrsiz, nener
logical bprint
integer iorder, iorderf, iorderc
integer norbit, norbitf, norbitc
integer nirrep, nirrepf, nirrepc
integer I000, I010, I020, I030, I040, I050, I060, I070, I080, I090
integer I100, I110, I120, I130, I140, I150, I160, I170, I180, I190
integer I200, I0
character*8 irrnm(32), label(32)
#include "control.com" /* for ROTPROJ */
#include "machsp.com"
CALL IGETREC(20,'JOBARC',DOIT//'ORDR',1,IORDERF)
CALL IGETREC(20,'JOBARC',DOIT//'NORB',1,NORBITF)
CALL IGETREC(20,'JOBARC','COMPORDR',1,IORDERC)
CALL IGETREC(20,'JOBARC','COMPNORB',1,NORBITC)
IORDER=MAX(IORDERF,IORDERC)
NORBIT=MAX(NORBITF,NORBITC)
I0 = 1
I000=I0
I010=I000 + IINTFP*IORDER*9
I020=I010 + IINTFP*IORDER*IORDER*9
I030=I020 + IINTFP*IORDER*IORDER
I040=I030 + IINTFP*IORDER*IORDER
I050=I040 + 3*IORDER
I060=I050 + IORDER*IORDER
I080=I060 + IORDER + IAND(IORDER,1)
I090=I080 + 6*IORDER
I100=I090 + IINTFP*3*IORDER
CALL CHRTABLE(IORDERF,ICORE(I000),ICORE(I010),ICORE(I020),
& ICORE(I030),ICORE(I040),ICORE(I050),ICORE(I060),
& IRRNM,ICORE(I080),DOIT,ICORE(I090))
CALL CHRTABLE(IORDERC,ICORE(I000),ICORE(I010),ICORE(I020),
& ICORE(I030),ICORE(I040),ICORE(I050),ICORE(I060),
& IRRNM,ICORE(I080),'COMP',ICORE(I090))
CALL IGETREC(-1,'JOBARC',DOIT//'NIRX',1,NIRREPF)
CALL IGETREC(-1,'JOBARC','COMPNIRX',1,NIRREPC)
NIRREP=MAX(NIRREPF,NIRREPC)
I010=I000 + IINTFP*NATOM*NATOM*9
I020=I010 + IINTFP*NATOM*NATOM*9
I030=I020 + IINTFP*NATOM*NATOM*9
I040=I030 + IINTFP*MAX(3*NATOM,NIRREPF*IORDER)
I050=I040 + IINTFP*MAX(6*NATOM,9*IORDER)
I060=I050 + IINTFP*MAX(6*NATOM,NIRREPF)
I060=I050
I070=I060 + IINTFP*9*NATOM*NATOM*3*NATOM
I080=I070 + MAX(MAX(2,IORDER)*NATOM,9*NATOM*NATOM)
I090=I080 + NATOM
I100=I090 + NATOM + IAND(NATOM,1)
I110=I100 + IINTFP*NATOM*NATOM*MAX(18,IORDER)
I120=I110 + IINTFP*NATOM*NATOM*18
I130=I120 + IINTFP*NATOM*NATOM*18
BPRINT =.TRUE.
CALL VIBINF(NATOM,NIRREPF,IORDERF,ICORE(I000),
& ICORE(I010),ICORE(I020),ICORE(I030),ICORE(I040),
& LABEL,ICORE(I060),ICORE(I070),ICORE(I080),
& ICORE(I090),ICORE(I100),DOIT)
CALL SYMADQ(NATOM,NIRREPC,IORDERC,NORBITC,ICORE(I000),
& ICORE(I010),ICORE(I020),ICORE(I030),ICORE(I040),
& LABEL,ICORE(I060),ICORE(I070),ICORE(I080),
& ICORE(I090),ICORE(I100),ICORE(I110),ICORE(I120),
& ICORE(I130),'COMP',1)
CALL TRAPRJ(NATOM,ICORE(I000),ICORE(I010),ICORE(I020),
& ICORE(I030))
IF (ROTPROJ) THEN
CALL ROTPRJ(NATOM,ICORE(I000),ICORE(I010),ICORE(I020),
& ICORE(I030))
END IF
CALL SCHMIDT(NATOM,ICORE(I010),ICORE(I020))
CALL COLLECT(NATOM,NIRREPC,ICORE(I000),
& ICORE(I010),ICORE(I020),ICORE(I030),LABEL,
& 'COMP')
IF (BPRINT) THEN
CALL PRTCOORD(NATOM,NIRREPC,0,ICORE(I000),ICORE(I010),
& LABEL,'COMP',.FALSE.)
END IF
CALL SYMADQ(NATOM,NIRREPF,IORDERF,NORBITF,ICORE(I000),
& ICORE(I010),ICORE(I020),ICORE(I030),ICORE(I040),
& LABEL,ICORE(I060),ICORE(I070),ICORE(I080),
& ICORE(I090),ICORE(I100),ICORE(I110),ICORE(I120),
& ICORE(I130),DOIT,2)
CALL PRDEGEN(NATOM,NIRREPF,IORDERF,NORBITF,ICORE(I000),
& ICORE(I010),ICORE(I020),ICORE(I030),ICORE(I040),
& LABEL,ICORE(I060),ICORE(I070),ICORE(I080),
& ICORE(I090),ICORE(I100),DOIT)
IF (BPRINT) THEN
CALL PRTCOORD(NATOM,NIRREPF,NIRREPC,ICORE(I000),ICORE(I010),
& LABEL,DOIT,.TRUE.)
END IF
I010=I000
I020=I010 + 3*NATOM
I030=I020 + 9*NATOM*NATOM
I040=I030 + 3*NATOM + IAND(NATOM,1)
I200=I040 + IINTFP*9*NATOM*NATOM*3*NATOM
#ifdef _DEBUG_LVL0
Print*, "Entering set points"
#endif
CALL SETPTS(NATOM,NIRREPF,DOIT,
& NENER,IRRNM,ICORE(I010),ICORE(I020),ICORE(I030),
& ICORE(I040),ICORE(I200),(ICRSIZ-I200+I0)/IINTFP)
return
c end subroutine init_fd
end
|
