-
Notifications
You must be signed in to change notification settings - Fork 2
/
CRTHERMO
258 lines (258 loc) · 7.89 KB
/
CRTHERMO
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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
C UNIVAC ANCI 77 VERSION, FORTRAN
COMMON /PAUX/ IE(101), IN(101), JE(7), KN(50), JN(7)
1,IS(5), PARA(20),JD, NJD
COMMON/CHARAC/REDUND,HI,HK,SPEC,OUT
CHARACTER*8 REDUND(7777)
CHARACTER*1 HI(101,2),HK(50,2),SPEC(5),OUT(22)
CHARACTER*30 PROFIL1,PROFIL2
INTEGER*4 S
dimension tapad(37)
C JANNAF.DAT: CONTAINS JANNAF DATA, IN BINARY FORM
irec=1
OPEN(UNIT=12,file='THERMO',FORM='UNFORMATTED',access='direct',
$ recl=152)
OPEN(UNIT=10,file='INPUT')
OPEN(UNIT=28,file='SCRATCH',FORM='UNFORMATTED')
OPEN(UNIT=17,file='PREPOST')
3 FORMAT (I2, 2A1, I1)
4 FORMAT (2A1,I1)
5 FORMAT (A1,I1)
10 FORMAT (15H0REDUNDANCY IN ,A8)
REWIND 28
DO 11 I = 1,97
READ (10,3)IE(I), HI(I,1), HI(I,2), IN(I)
11 IF (ICHAR(HI(I,2)) .LE. 90 .AND. ICHAR(HI(I,2)) .GE. 65)
$HI(I,2) = CHAR(ICHAR(HI(I,2))+32)
DO 12 I = 1,22
12 READ (10,4)HK(I,1), HK(I,2), KN(I)
DO 13 I = 1,5
13 READ (10,5)SPEC(I), IS(I)
HI(98,1) = SPEC(4)
HI(99,1) = SPEC(5)
HI(98,2) = HK(I,1)
HI(99,2) = HK(I,1)
CALL SHOJAN
CALL NONJAN
DO 110 K = 1,2
REWIND 28
LIM = JD + NJD
DO 108 I = 1,LIM
READ (28) KHASE,REDUND(I),S, (JN(L), JE(L), L = 1,7)
READ (28) (PARA(L), L = 1,10)
READ (28) (PARA(L), L = 11,20)
IF (I .LE. JD) GO TO 107
IF (K .EQ. 2) GO TO 107
LII = I-1
DO 105 J = 1,LII
IF (REDUND(J) .EQ. REDUND(I)) GO TO 109
105 CONTINUE
107 GO TO (50,55), K
50 IF (KHASE - 1) 108,51,108
51 irec=irec+1
WRITE(12,rec=irec) KHASE,REDUND(I),S,(JN(L),JE(L),L=1,7),
$ (PARA(L),L=1,20)
WRITE (17,6666) KHASE, REDUND(I), (JN(L), JE(L),
1 L = 1,7), (PARA(L), L = 1,20),S
6666 FORMAT (I5, A8, 9X, 14I3/ 10E12.4/10E12.4,I5)
GO TO 108
55 IF (KHASE-1) 108,108,51
109 WRITE (17,10)REDUND(I)
108 CONTINUE
110 CONTINUE
KHASE = -1
irec=irec-1
write (12,rec=1) irec,tapad
WRITE (6,6420) irec
6420 FORMAT (5X,'CRTHERMO WORKED SUCCESSFULLY.'/
$ 4x,i5,' COMBUSTION RECORDS WRITTEN TO THERMO')
CLOSE(UNIT=10)
CLOSE(UNIT=17)
CLOSE(UNIT=28,status='delete')
stop
END
SUBROUTINE SHOJAN
C . . . . SUBROUTINE TO DIGEST JANAF DATA AS FITTED BY HOWARD SHOMATE.
COMMON /PAUX/ IE(101), IN(101), JE(7), KN(50), JN(7)
1,IS(5), PARA(20),JD, NJD
COMMON/CHARAC/REDUND,HI,HK,SPEC,OUT
CHARACTER*8 REDUND(7777)
CHARACTER*1 HI(101,2),HK(50,2),SPEC(5),OUT(22)
CHARACTER*1 CRAZE(3),ELM(6,3),PHASE
CHARACTER*30 HOL
DIMENSION NA(6),A(2),B(2),C(2),D(2),E(2),F(2),G(2),H(2),
1 TL(2),TU(2)
INTEGER S,SA
DATA (CRAZE(I), I = 1,3)/ 'C', 'G', 'L' /
1 FORMAT (A30, 5X, A1, 11X, 6(2A1, I2), 1X, I6)
3 FORMAT (4(F13.0), F5.0, 3X, F5.0, 8X, I5)
4 FORMAT (7H0MIX UP ,2I9)
JD = 0
JN(7) = 0
101 READ (10,1) HOL, PHASE, ((ELM(I,J),J=1,2),NA(I),I=1,6),S
102 IFIRST = 0
103 DO 11 I = 1,18
11 OUT(I) = SPEC(1)
IF (NA(1) .EQ. 0) RETURN
C . . . . IF NO ATOM COUNT, SHOJAN IS FINIISHED.
JD = JD + 1
INDEX = 1
DO 9 I = 1,7
JN(I) = 0
9 JE(I) = 0
DO 17 I = 1,99
DO 16 J = 1,6
C . . . . COMPARE ASCII WITH PERIODIC TABLE.
IF (HI(I,1) .NE. ELM(J,1)) GO TO 16
K = NA(J)
IF (I .GE. 98) GO TO 12
IF (HI(I,2) .EQ. ELM(J,2)) GO TO 10
IF(ICHAR(HI(I,2))-32 .EQ. ICHAR(ELM(J,2))) GO TO 10
GO TO 16
10 OUT(INDEX) = HI(I,1)
OUT(INDEX+1) = HI(I,2)
INDEX = INDEX + IN(I)
OUT(INDEX) = HK(K,1)
OUT(INDEX+1) = HK(K,2)
INDEX = INDEX + KN(K)
JN(J) = K
JE(J) = IE(I)
GO TO 17
C . . . . ATTACH CHARGE APPENDAGES.
12 DO 13 L = 1,K
OUT(INDEX) = ELM(J,1)
13 INDEX = INDEX + 1
JN(J) = K
JE(J) = 0
IF (I .EQ. 98) JN(J) = -K
GO TO 17
16 CONTINUE
17 CONTINUE
IF (JE(1) .NE. 0) GO TO 18
OUT(2) = OUT(1)
OUT(1) = 'E'
C . . . . ATTACH PHASE IDENTIFICATION APPENDAGE.
18 KHASE = 2
IF (PHASE .EQ. CRAZE(1)) OUT(INDEX) = SPEC(2)
IF (PHASE .EQ. CRAZE(2)) KHASE = 1
IF (PHASE .EQ. CRAZE(3)) OUT(INDEX) = SPEC(3)
REDUND(1)=OUT(1)//OUT(2)//OUT(3)//OUT(4)//OUT(5)//OUT(6)//
XOUT(7)//OUT(8)
WRITE(17,2)REDUND(1)
2 FORMAT(' J ',A8)
WRITE (28) KHASE,REDUND(1),S, (JN(L), JE(L), L = 1,7)
IKF=1
87 READ (10,3) A(IKF),B(IKF),C(IKF),D(IKF),TL(IKF),TU(IKF),SA
IF (S .NE. SA) WRITE (17,4) S,SA
READ (10,3) E(IKF),F(IKF),G(IKF),H(IKF),TL(IKF),TU(IKF),SA
IF (S .NE. SA) WRITE (17,4) S,SA
READ (10,1) HOL, PHASE, ((ELM(I,J),J=1,2),NA(I),I=1,6),S
IF (S .NE. SA) GO TO 89
C IF (PHASE .NE. CRAZE(2)) GO TO 89
C IF (IFIRST .NE. 0) GO TO 88
IFIRST = 1
IKF=2
GO TO 87
C 88 WRITE (28) A,B,C,D,E,F,G,H,TL,TU
C READ (10,3) A,B,C,D,TL,TU,SA
C IF (S .NE. SA) WRITE (17,4) S,SA
C READ (10,3) E,F,G,H,TL,TU,SA
C IF (S .NE. SA) WRITE (17,4) S,SA
C WRITE (28) A,B,C,D,E,F,G,H,TL,TU
C GO TO 101
89 IKF=1
WRITE (28) A(IKF),B(IKF),C(IKF),D(IKF),E(IKF),F(IKF),
1 G(IKF),H(IKF),TL(IKF),TU(IKF)
IF(IFIRST.GT.0) IKF=2
WRITE (28) A(IKF),B(IKF),C(IKF),D(IKF),E(IKF),F(IKF),
1 G(IKF),H(IKF),TL(IKF),TU(IKF)
GO TO 102
END
SUBROUTINE NONJAN
C . . . . THIS SUBROUTINE PROCESSES NON JANAF TYPE DATA ACCORDING TO DOW
C . . . . AND OLD NOTS (NAVWEPS 7043) FORMATS.
COMMON /PAUX/ IE(101), IN(101), JE(7), KN(50), JN(7)
1,IS(5), PARA(20),JD, NJD
COMMON/CHARAC/REDUND,HI,HK,SPEC,OUT
CHARACTER*8 REDUND(7777)
CHARACTER*1 HI(101,2),HK(50,2),SPEC(5),OUT(22)
1 FORMAT (14I3, 28X, I1)
6 FORMAT (4E13.0)
7 FORMAT (6E9.6,2F6.0,I1)
NJD = 0
DO 99 LIM = 1,7777
DO 98 I = 1,18
98 OUT(I) = SPEC(1)
READ (10,1)(JN(I), JE(I), I = 1,7),KHASE
IF (JN(1) .EQ. 0) GO TO 100
C . . . . IF NO ATOM COUNT,SKIP OUT.
NJD = NJD + 1
29 IF (KHASE) 30,31,30
30 READ (10,6) A, B, C, D, E, F, G, H
TL = 298.
TU = 6000.
JAN = 1
GO TO 32
31 READ (10,7)(PARA(I), I = 1,8),KHASE,(PARA(I),I = 9,16)
JAN = 2
32 INDEX = 1
DO 17 I = 1,97
DO 16 J = 1,7
KK = J
IF (JN(J)) 14,17,14
14 IF (IE(I) - JE(J)) 16,15,16
15 OUT(INDEX) = HI(I,1)
OUT(INDEX+1) = HI(I,2)
INDEX = INDEX + IN(I)
K = JN(J)
OUT(INDEX) =HK(K,1)
OUT(INDEX+1) = HK(K,2)
INDEX = INDEX + KN(K)
GO TO 17
16 CONTINUE
17 CONTINUE
OUT(INDEX) = SPEC(KHASE)
INDEX = INDEX + IS(KHASE)
IF (JE(1) .NE. 0) GO TO 23
IF (INDEX .NE. 1) GO TO 18
OUT(INDEX) = 'E'
INDEX = 2
18 IAB = ABS(JN(1))
IF (JN(1)) 19,23,21
19 DO 20 I = 1,IAB
OUT(INDEX) = SPEC(4)
20 INDEX = INDEX + IS(4)
GO TO 23
21 DO 22 I = 1,IAB
OUT(INDEX)=SPEC(5)
22 INDEX = INDEX + IS(5)
23 REDUND(1)=OUT(1)//OUT(2)//OUT(3)//OUT(4)//
XOUT(5)//OUT(6)//OUT(7)//OUT(8)
WRITE(17,2)REDUND(1)
2 FORMAT(' N ',A8)
WRITE(28) KHASE, REDUND(1), NJD, (JN(L), JE(L), L = 1,7)
IF (JAN .EQ. 2) CALL CONVER (PARA(1),A,B,C,D,E,F,G,H,TL,TU)
WRITE (28) A,B,C,D,E,F,G,H,TL,TU
IF (JAN .EQ. 2) CALL CONVER (PARA(9),A,B,C,D,E,F,G,H,TL,TU)
WRITE (28) A,B,C,D,E,F,G,H,TL,TU
99 CONTINUE
100 RETURN
END
SUBROUTINE CONVER (PARA, A,B,C,D,E,F,G,H,TL,TU)
C . . . . SUBROUTINE TO CONVERT OLD PARAMETRIC FORMS TO NEW PARAMETRIC F
DIMENSION PARA(20)
A = PARA(3)
B = PARA(4)*1000.
C = 0.
D = 0.
E = PARA(5)/1000000.
F = PARA(1) + PARA(2) - PARA(3)*3000. - PARA(4)*4500000.
1 + PARA(5)/3000.
F = F/1000.
G = PARA(6) - PARA(3)*ALOG(3000.) - PARA(4)*3000.
C 1 + PARA(5)/4500000. + ALOG(1000.)
1 + 0.5*PARA(5)/9000000. + PARA(3)*ALOG(1000.)
H = PARA(1)/1000.
TL = PARA(7)
TU = PARA(8)
RETURN
END