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
|
SUBROUTINE PROCOM (PROCOS,PROCOF,CASECC,NCOEFS,NGRIDS)
C
C PROCOM COMBINES PROCOF CASES FOR SUBCOM-S AND REPCASES
C
INTEGER PROCOF,CASECC,BUF1,BUF2,BUF3,FILE,PROCOS,INFO(7),
1 IZ(1),NAM(2)
COMMON /SYSTEM/ IBUF
COMMON /ZZZZZZ/ Z(1)
EQUIVALENCE (Z(1),IZ(1))
DATA I166 , I16 ,NAM / 166, 16, 4HPROC,4HOM /
C
LCORE = KORSZ(Z)
BUF1 = LCORE - IBUF + 1
BUF2 = BUF1 - IBUF
BUF3 = BUF2 - IBUF
LCORE = BUF3 - 1
IF (LCORE.LT.NCOEFS .OR. LCORE.LT.NGRIDS) GO TO 108
CALL GOPEN (PROCOS,Z(BUF1),0)
CALL GOPEN (PROCOF,Z(BUF2),1)
C
C CHECK EACH SUBCASE FOR REPCASE OR SUBCOM-IF NONE(JUST COPY SET OF
C 5 RECORDS FROM PROCOS TO PROCOF
C
FILE = CASECC
CALL GOPEN (CASECC,Z(BUF3),0)
10 FILE = CASECC
CALL READ (*90,*20,CASECC,Z(1),LCORE,0,IWORDS)
GO TO 108
20 IF (IZ(I16) .NE. 0) GO TO 30
C
C NOT A SUBCOM - MIGHT BE REPCASE
C
25 FILE = PROCOS
CALL FREAD (PROCOS,Z,103,1)
CALL WRITE (PROCOF,Z,103,1)
CALL FREAD (PROCOS,Z,NCOEFS,1)
CALL WRITE (PROCOF,Z,NCOEFS,1)
CALL FREAD (PROCOS,Z,NCOEFS,1)
CALL WRITE (PROCOF,Z,NCOEFS,1)
CALL FREAD (PROCOS,Z,NGRIDS,1)
CALL WRITE (PROCOF,Z,NGRIDS,1)
CALL FREAD (PROCOS,Z,NGRIDS,1)
CALL WRITE (PROCOF,Z,NGRIDS,1)
C
C GO BACK FOR ANOTHER CASE CONTROL RECORD
C
GO TO 10
C
C REPCASE OR SUBCOM
C
30 IF (IZ(I16) .GT. 0) GO TO 45
C
C REPCASE
C
DO 40 I = 1,5
CALL BCKREC (PROCOS)
40 CONTINUE
GO TO 25
C
C SUBCOM
C
45 LCC = IZ(I166)
LSYM = IZ(LCC)
DO 50 I = 1,LSYM
DO 50 J = 1,5
CALL BCKREC (PROCOS)
50 CONTINUE
NTOT = 2*(NCOEFS+NGRIDS)
IF (IWORDS+2*NTOT .GT. LCORE) GO TO 108
INEW = IWORDS + NTOT
DO 60 I = 1,NTOT
60 Z(INEW+I) = 0.
DO 80 I = 1,LSYM
COEF = Z(LCC+I)
IF (COEF .EQ. 0.) GO TO 75
CALL FREAD (PROCOS,INFO,103,1)
CALL FREAD (PROCOS,Z(IWORDS+1),NCOEFS,1)
CALL FREAD (PROCOS,Z(IWORDS+NCOEFS+1),NCOEFS,1)
CALL FREAD (PROCOS,Z(IWORDS+2*NCOEFS+1),NGRIDS,1)
CALL FREAD (PROCOS,Z(IWORDS+2*NCOEFS+NGRIDS+1),NGRIDS,1)
DO 70 J = 1,NTOT
Z(INEW+J) = Z(INEW+J) + COEF*Z(IWORDS+J)
70 CONTINUE
GO TO 80
75 DO 76 K = 1,5
CALL FWDREC (*102,PROCOS)
76 CONTINUE
C
80 CONTINUE
C
C WRITE TO PROCOF- 1ST BE SURE THAT ISYM IS 0 TO ACCOUNT FOR
C POSSIBLE SYMMETRY-ANTISYMMETRY COMBINATION
C
INFO(6) = 0
CALL WRITE (PROCOF,INFO,103,1)
CALL WRITE (PROCOF,Z(INEW+1),NCOEFS,1)
CALL WRITE (PROCOF,Z(INEW+NCOEFS+1),NCOEFS,1)
CALL WRITE (PROCOF,Z(INEW+2*NCOEFS+1),NGRIDS,1)
CALL WRITE (PROCOF,Z(INEW+2*NCOEFS+NGRIDS+1),NGRIDS,1)
C
C GO BACK FOR ANOTHER SUBCASE
C
GO TO 10
C
C DONE
C
90 CALL CLOSE (CASECC,1)
CALL CLOSE (PROCOS,1)
CALL CLOSE (PROCOF,1)
INFO(1) = PROCOS
CALL RDTRL (INFO)
INFO(1) = PROCOF
CALL WRTTRL (INFO)
RETURN
C
102 CALL MESAGE (-2,0,NAM)
108 CALL MESAGE (-8,0,NAM)
RETURN
END
|
