Context Navigation

cross97.f_org @ 848

Last change on this file since 848 was 1, checked in by cbipsl, 18 years ago
Geisa inital import
File size: 25.0 KB

Line
1	C CROSS SECTIONS DATA BASE MANAGEMENT PROGRAM
2	C VERSION 2.5 for INTERNET
3	C 8 June 1998
4	C
5	CHARACTER*180 LINE, Path, Path1
6	CHARACTER*255 FMol, Lines(10),LinesCom
7	Character*27 Str ! 27 for UNIX
8	CHARACTER*30 B_Name, Idx_Name, Extr_Name,Extr_Idx
9	CHARACTER*3 CHN,StCode
10	CHARACTER*10 S10
11	INTEGER*2 NmbMol, LeNumerodeMol, MaxMol, NtpCode, ilen,MaxLine
12	Integer*4 NmIdx,NmLines,NmNewLines,NuLn,Ndc,ExtLn
13	REAL*4 LowerWn, UpperWn, FromWv, ToWv,Step, Lepremier,Nu1,Nu2
14	INTEGER*2 NLines1
15	TYPE MOLECULES
16	SEQUENCE
17	CHARACTER*10 NAME
18	INTEGER*2 MCODE ! The code of molecule
19	INTEGER*2 NTP ! Number of data sets
20	INTEGER*2 N1(4) ! From
21	INTEGER*2 N2(4) ! TO
22	END TYPE MOLECULES
23	Type CONDITIONS
24	SEQUENCE
25	REAL*4 Temperature
26	REAL*4 Pressure
27	REAL*4 Resolution
28	END TYPE CONDITIONS
29	TYPE (MOLECULES) ListofMol(30)
30	TYPE (CONDITIONS) AllCondit(200)
31	INTEGER*4 I,J,K, N1(4),N2(4),RR
32	Integer*2 WhatMol(30), WhatTemp(10),Code,jjj, T_P(250,50)
33	Integer*2 Mol_Nm(30),NumSel,LeNumero,NmbofMol,NTP(30)
34	Integer*2 MCode1
35	CHARACTER*10 Name, WAIT
36	Character*10 MolecName
37	Integer*4 Idx(2500),Idx1(2500)
38	CHARACTER*3 OPT
39	CHARACTER*11 MOL(30) !!!!
40	COMMON /REG1/ RR,MaxLine,NmLines,NmIdx,jjj, Code, WhatTemp
41	COMMON /REG2/ Idx
42	COMMON /REG3/ B_Name,Path
43	COMMON /REG4/ LowerWn,UpperWn,Step
44	Common /REG5/ NuLn,Ndc,ExtLn
45	Common /Reg6/ Idx1
46	Common /Reg7/ Lepremier,NumSel,NmbofMol
47	Common /Reg8/ WhatMol,T_P,Mol_Nm
48	Common /Reg9/ ListofMol
49	C Common /Reg10/ LowerWn, UpperWn
50	Common /Reg11/ AllCondit
51	Common /Reg12/ Path1
52	Common /Reg13/ Mol
53	C ************************************************************
54	C MAIN PROGRAM
55	C ****** **************************************************
56	RR=27 ! 27 for the UNIX version!
57	MaxLine=1150 ! Max number of records contained in a block to be extracted
58	Step=2.0 ! Step for indexation
59	C SCommand='clear' ! clear for UNIX
60	NuLn=0
61	Ndc=3
62	c CALL System(SCommand)
63	c Call LaPremiere
64	c Call System(SCommand)
65	Path=''
66	Path1='/users/invite/alexei/CROSS_INTER/CRS97/'
67	ilen=Index(Path,' ')-1
68	ilen1=Index(Path1,' ')-1
69	FMol= Path1(1:ilen1)//'molec.dat'
70	OPEN(10,FILE=FMol,STATUS='OLD', ERR=8888,iostat=iosml)
71	OPEN(11,FILE=Path1(1:ilen1)//'numbers.dat',
72	$FORM='FORMATTED',STATUS='OLD',ERR=8888,iostat=iosnm)
73	C * Name of the data file and its index file *
74
75	B_Name='/datageisa/data/cross_97.asc'
76	Idx_Name='cross97.idx'
77	DO 1666 I20=1,250
78	DO 1666 J20=1,50
79	1666 T_P(I20,J20)=0
80	DO 1667 I20=1,30
81	C NTP(I20)=0
82	1667 Mol(I20)='***'
83	C READ OF THE PROGRAM PARAMETERS
84	NmbofMol=1
85	1 READ(10,'(A10,I3,1X,I2,8I3)', IOSTAT=ios,END=2)
86	$Name, Code,I,N1(1),N2(1),N1(2),N2(2),N1(3),N2(3),
87	$N1(4),N2(4)
88	ListofMol(NmbofMol)%Name=Name
89	ListofMol(NmbofMol)%MCode=Code
90	ListofMol(NmbofMol)%NTP=I
91	Mol_Nm(NmbofMol)=Code
92	DO 40 J=1,I
93	ListofMol(NmbofMol)%N1(j)=N1(j)
94	40 ListofMol(NmbofMol)%N2(j)=N2(j)
95	NmbofMol=NmbofMol+1
96	GO TO 1
97	C NmbofMol=NmbofMol-1 ! Attention !!!
98
99	2 Close(10)
100	I=1
101	3 READ(11,'(I3,2X,F5.1,F12.2,8X,F6.4)',END=7) J,
102	$AllCondit(I)%Temperature, AllCondit(I)%Pressure,
103	$AllCondit(I)%Resolution
104	i=i+1
105	GO TO 3
106	c 5 CLOSE(11)
107	C ** READ OF THE INPUT PARAMETERS ***********
108	NLines1=1
109	7 READ (*,'(A255)',end=334) LinesCom !1st line
110	if (Nlines1.EQ.0) Nlines1=1
111	Lines(NLines1)=LinesCom
112	ill=INDEX(LinesCom,' ')-1
113	DO 333 i34=1,ill
114	333 if (LinesCom(i34:i34).EQ.'/') go to 334
115	C Print *, Nlines1,'&',Lines(NLines1)
116	NLines1=NLines1+1
117	if (NLINES.GT.10) then
118	Write(0,*) 'Too many input lines (it has to be <=10)'
119	Call Exit(1)
120	end if
121	go to 7
122	C ______________________________________________________
123	334 Call LireParam(Lines,NLines1,OPT,Nu1,Nu2)
124	C Print *,'!! ',Mol(1),'&',Mol(2),'&',Mol(3)
125	C Print , '************ GEISA CROSS-97 *************'
126	C Print *, ' '
127	C Print *,' The input parameters '
128	C Print *, ' '
129	C Print *, 'OPT=',opt
130	C if (OPT.NE.'cal') go to 335
131	c
132	C Print *, 'The selected molecules and (T,P) codes: '
133	C DO 188 I20=1, NmbofMol-1 !without 'all'
134	c if (Mol(i20).NE.'***') then
135	c Call CodeMol(Mol(I20),MCode1)
136	c else
137	c go to 335
138	c end if
139	c
140	c DO 1888 J20=1,NmbofMol
141	cc
142	c if (MCode1.EQ.Mol_Nm(J20)) then
143	c LN=0
144	c DO 999 k20=1,50
145	c 999 if (T_P(J20,K20).NE.0) LN=LN+1
146	c if (LN.EQ.0) LN=1
147	c Print *,Mol(i20),': ',(T_P(J20,KK),KK=1,LN)
148	c go to 188c
149	c end if
150	c 1888 Continue
151	c 188 Continue
152	c 335 Print ,'*********************************************'
153	if (OPT.EQ.'lst') go to 602
154	if (OPT.EQ.'mco') then
155	Call MCodes
156	Call Exit(0)
157	end if
158	if (OPT.EQ.'ltp') then
159	Call List_TP
160	Call Exit(0)
161	end if
162
163	NumSel=0
164	FromWv=Nu1
165	ToWv=Nu2
166	Nglob=0
167	333 if (Mol(1).EQ.'all') then
168	Code=0 ! Select all the data available
169	jjj=1
170	WhatTemp(1)=0
171	go to 602
172	end if
173	338 NumSel=NumSel+1
174	if (Mol(NumSel).EQ.'***') then
175	NumSel=NumSel-1
176	go to 602
177	end if
178	Call CodeMol(Mol(NumSel),Code)
179	WhatMol(NumSel)=Code
180	go to 338
181	602 ilen=INDEX(Path,' ')-1
182	OPEN(60,File=Path(1:ilen)//B_Name,
183	$ Status='OLD',Form='UNFORMATTED',Access='DIRECT',Recl=RR,
184	$ Err=8888, iostat=iosban)
185	OPEN(66,File=Path1(1:ilen1)//Idx_Name,Status='Old',
186	$ Err=8888, iostat=iosidx)
187	Read(66,'(I10)') NmIdx ! Number of index file components
188	Read(66,'(I10)') NmLines ! Number of the data bank entries
189	DO 499 i=1,NmIdx-2
190	Read(66,'(I10)') Idx(i)
191	c Print *,'Idx(',i,')=',Idx(i)
192	499 Continue
193	Close(66)
194	Read(60,Rec=1) Str
195	S10=Str(1:10)
196	Read(S10,'(F10.6)') LowerWn
197	Read(60,Rec=NmLines) Str
198	S10=Str(1:10)
199	Read(S10,'(F10.6)') UpperWn
200	Close(60)
201	if (OPT.EQ.'lst') then
202	Call MolCodes
203	Call Exit(0)
204	end if
205	Extr_Name='ex_bnc'
206	Call Extraction(FromWv,ToWv,Extr_Name)
207	C Call System('cat '//Extr_Name)
208
209	9999 Call Exit(0)
210	8888 if (iosml.EQ.6) Write(0,*) 'File molec.dat not found!'
211	if (iosnm.EQ.6) Write(0,*) 'File numbers.dat not found!'
212	if (iosban.EQ.6) Write(0,*) 'CRS data bank not found!'
213	if (iosidx.EQ.6) Write(0,*) 'Index file cross97.idx not found!'
214	Write(0,*) 'The program is stoped'
215	Call Exit(1)
216	END
217	c Subroutines
218	c
219	SUBROUTINE Extraction(From,to1,Out)
220	Real*4 From,to1,LePremier
221	Real*4 Freq,LowerWn,UpperWn,Step
222	Integer*2 MaxLine,jjj,code,MCode,TPCode,WhatTemp(10),WhatMol(30)
223	Integer*2 Mol_Nm(30),NumSel,LeNumero,NmbofMol,T_P(250,50)
224	Integer*4 NmIdx,NmLines, BlockLen,ExtLn,NRec,RR,Idx(2500)
225	Integer*4 NFact,Ninit,Irec,InitRec,NuLn,Ndc, MolLn(250)
226	Character*30 B_Name,Out,Idx_File
227	Character*3 S3
228	Character*10 S10
229	Character*11 Mol(30) !!!!
230	CHARACTER*180 Path,out1
231	Integer*2 OutUnit
232	Character*27 Lines(1150),ExtLines(1150),Str,Line ! 27 for UNIX
233	COMMON /REG1/ RR,MaxLine,NmLines,NmIdx,jjj, Code, WhatTemp
234	COMMON /REG2/ Idx
235	Common /REG3/ B_Name,Path
236	Common /REG4/ LowerWn,UpperWn,Step
237	Common /Reg5/ Nuln,Ndc,ExtLn
238	Common /REG7/ LePremier, NumSel,NmbofMol
239	Common /Reg8/ WhatMol, T_P ,Mol_Nm
240	Common /REG13/MOL
241	c n100=Int((From-LowerWn)/Step)+1
242	OutUnit=70 ! Set up output unit
243	ilen=INDEX(Out,'.')
244	if (ilen.NE.0) Idx_File=Out(1:ilen)//'idx'
245	if (ilen.EQ.0) then
246	ilen=INDEX(Out,' ')-1
247	Idx_File=Out(1:ilen)//'.idx'
248	end if
249	n100=(Int(From)-Int(LowerWn))/Int(step)+1
250	n200=(Int(to1)-Int(LowerWn))/Int(step)+2
251	if (N100.GT.NmIdx-2) N100=NmIdx-2
252	if (N100.LT.1) N100=1
253	if (N200.GT.NmIdx-2) N200=NmIdx-2
254	if (N200.LT.1) N200=1
255	NInit=Idx(n100)
256	DO 3131 I=1,250
257	3131 MolLn(i)=0
258	C NFact=NmLines-NInit+1 ! old !!
259	NFact=Idx(n200)-NInit+1
260	if (NFact.LE.MaxLine) BlockLen=NFact
261	if (NFact.GT.MaxLine) BlockLen=MaxLine
262	ilen=INDEX(Path,' ')-1
263	OPEN(60,File=Path(1:ilen)//B_Name,
264	$ Status='OLD',Form='UNFORMATTED',Access='DIRECT',Recl=BlockLen*rr,
265	$Err=888)
266	OPEN(Unit=OutUnit,Form='UNFORMATTED',ACCESS='DIRECT',
267	$Status='SCRATCH',Recl=MaxLine*rr)
268
269	N=NFact/BlockLen
270	NN=MOD(NFact,BlockLen)
271	ExtLn=0
272	IFact=0
273	Irec=1
274	InitRec =NInit/BlockLen+1
275	c Print *, 'Scaning the data base from the entry N ', Ninit
276	c * Block-by-block reading the data file *
277	c
278	DO 1150 i=1,N
279	Read(60,Rec=InitRec) Lines
280	InitRec=InitRec+1
281	DO 101 j=1,BlockLen
282	S10=Lines(j)(1:10)
283	Read(S10,'(F10.6)')Freq
284	if (Freq.GT.to1) go to 1250
285	if (Freq.LT.From) go to 101
286	if (Code.EQ.0) go to 105
287	S3=Lines(j)(21:23)
288	Read(S3,'(I3)') MCode
289	DO 277 I20=1,NumSel
290	if (MCode.EQ.WhatMol(i20)) go to 191 ! was: 115
291	277 CONTINUE
292	go to 101
293	C 115 DO 188 I20=1, NmbofMol
294	c if (MCode.EQ.Mol_Nm(I20)) then
295	c LeNumero=I20
296	c go to 191
297	c end if
298	c 188 Continue
299	191 if (T_P(MCode,1).EQ.0) go to 105
300
301	S3=Lines(j)(24:26)
302	Read(S3,'(I3)') TPCode
303
304	C if (MCode.NE.Code) go to 109
305	C
306	C 111 if (Freq.GT.to1) go to 1250
307	C if (Freq.LT.From) go to 101
308	DO 103 jj=1,50
309	if (T_P(MCode,jj).EQ.0) go to 101
310	103 if (T_P(MCode,jj).EQ.TPCode) go to 105
311	114 go to 101
312	105 ExtLn=ExtLn+1
313	MolLn(Mcode)=MolLn(MCode)+1
314	IFact=IFact+1
315	ExtLines(IFact)=Lines(j)
316	if (ExtLn.EQ.1) LePremier=Freq
317	C Call Index1(Idx_File,1,Freq,Step)
318	C if (Mod(ExtLn,200).EQ.0) Print *, ExtLn, ' lines rewritten'
319	if (IFACT.GE.BlockLen) then
320	Write(OutUnit,Rec=IRec) ExtLines
321	IRec=Irec+1
322	IFact=0
323	End if
324
325	C 109 if (Freq.GT.to1) go to 1250
326	101 Continue
327	1150 Continue
328	1250 Continue
329	INQUIRE(unit=OutUnit,name=out1)
330	Call System('cat '//out1)
331	Close(OutUnit)
332
333	C Open(Unit=OutUnit,File=Out,Status='Old',Form='UNFORMATTED',
334	C $ACCESS='DIRECT',Recl=rr)
335	IREC=(IREC-1)*BlockLen+1
336	if (N.NE.0) then
337	DO 1212 i=1,IFact
338	C Write(OutUnit,Rec=Irec) ExtLines(i)
339	Write(6,'(A26)') ExtLines(i)(1:26) !(1:27) for PC
340	1212 Irec=Irec+1
341	end if
342	Close(60)
343	C if (Freq.GT.to1) go to 1213 !!! suprimer le 29 mai 1998
344
345	cc Line-by-line reading the data bank file
346
347	OPEN(60,File=Path(1:ilen)//B_Name,
348	$ Status='OLD',Form='UNFORMATTED',Access='DIRECT',Recl=rr,
349	$Err=888)
350	InitRec=(InitRec-1)*BlockLen+1
351	DO 777 i=1,nn
352	READ(60,Rec=InitRec) Line
353	cc ------------------------------------------------------------------
354	InitRec=InitRec+1
355	S3=Line(21:23)
356	Read(S3,'(I3)') MCode
357	S3=Line(24:26)
358	Read(S3,'(I3)') TPCode
359	S10=Line(1:10)
360	Read(S10,'(F10.6)') Freq
361	if (Code.EQ.0) go to 177
362	C if (MCode.NE.Code) go to 777
363	DO 377 I20=1,NumSel
364	if (MCode.EQ.WhatMol(i20)) go to 177
365	377 CONTINUE
366	Go to 777
367
368
369	177 if (Freq.GT.to1) go to 1213
370	if (Freq.LT.From) go to 777
371
372	c DO 1888 I20=1, NmbofMol
373	c if (MCode.EQ.Mol_Nm(I20)) then
374	c LeNumero=I20
375	c go to 991
376	c end if
377	c1888 Continue
378
379	991 if (T_P(MCode,1).EQ.0) go to 106
380	DO 104 jj=1,50
381	if (T_P(MCode,jj).EQ.0) go to 666
382	104 if (T_P(MCode,jj).EQ.TPCode) go to 106
383	666 go to 777
384	106 ExtLn=ExtLn+1
385	If (ExtLn.EQ.1) then LePremier=Freq
386	MolLn(MCode)=MolLn(MCode)+1
387	C Call INDEX1(Idx_File,1,Freq,Step)
388	C if (Mod(ExtLn,200).EQ.0) Print *, ExtLn, ' lines rewritten'
389	C Write(OutUnit,Rec=IRec) Line
390	Write(6,'(A26)') Line(1:26) ! 26 for Unix, 27 -for PC
391	IREC=IREC+1
392	777 Continue
393	cc --------------------------------------------------------------------
394
395	C1213 Close(OutUnit)
396	1213 Print *, 'The selected molecules: '
397	DO 1188 I20=1, NmbofMol-1 !without 'all'
398	if (Mol(1).EQ.'all') then
399	Print *, 'All molecules have been selected'
400	go to 1189
401	end if
402	if (Mol(i20).NE.'***') then
403	Call CodeMol(Mol(i20),mcode)
404	C Print *,Mol(i20),' ', MolLn(mcode),' lines rewritten'
405	write(6,'(A10,1X,I8,A17)')
406	$ Mol(i20),MolLn(mcode),' lines rewritten'
407	end if
408	1188 Continue
409	1189 Write(*,7890) 'Spectral range: ', from,' - ',to1
410	Print *, 'Total: ',ExtLn, ' lines rewritten'
411	C if (ExtLn.NE.0) Call Index1(Idx_File,0,0.0,Step)
412	RETURN
413	888 Write(0,*) 'File opening error'
414	7890 FORMAT(A16,F10.3,A3,F10.3)
415	Call Exit(1)
416	END
417
418	SUBROUTINE INDEX1(Nm_Idx,Last,Freq,Step)
419	Real*4 Freq,CurrF,Step,LePremier
420	Integer*4 Idx1(2500),NuLn,Ndc,ExtLn
421	Character*30 Nm_Idx
422	Common /Reg5/ Nuln,Ndc,ExtLn
423	Common /Reg6/Idx1
424	Common /Reg7/ CurrF
425	If (Last.EQ.0) then
426	Idx1(1)=Ndc ! Total length of *.idx file
427	Idx1(2)=ExtLn ! Number of entries in the data bank
428	Idx1(3)=1 !
429	OPEN(33,File=Nm_Idx,Status='UNKNOWN')
430	DO 30 i=1,Ndc
431	Write(33,'(I10)') Idx1(i)
432	30 CONTINUE
433	Close(33)
434	Return
435	end if
436	MaxIdx=2500
437	NuLn=Nuln+1
438	if (Int(Freq).GE.Int(CurrF+Step)) then
439	n1=(Int(Freq)-Int(CurrF))/Int(Step)
440	do 22 i=0,nl
441	ndc=ndc+1
442	if (ndc.gt.MaxIdx) then
443	Write(0,*) 'Can not index this file!'
444	Call Exit(1)
445	end if
446	NuLn1=NuLn
447	if (NuLn1.LT.1) NuLn1=Nuln
448	Idx1(Ndc)=NuLn1
449	22 CurrF=CurrF+Step
450	end if
451	Return
452	End
453
454	SUBROUTINE CodeMol(Nm,C)
455	TYPE MOLECULES
456	SEQUENCE
457	CHARACTER*10 NAME
458	INTEGER*2 MCODE ! The code of molecule
459	INTEGER*2 NTP ! Number of data sets
460	INTEGER*2 N1(4) ! From
461	INTEGER*2 N2(4) ! TO
462	END TYPE MOLECULES
463	CHARACTER*11 Nm, Nlm !!!!
464	Integer*2 C, NmbofMol,NumSel
465	Type (Molecules) ListofMol(30)
466	Real*4 LePremier
467	Common /REG9/ ListofMol
468	Common /Reg7/ Lepremier,NumSel,NmbofMol
469	ilen=INDEX(Nm,' ')-1
470	Nm=Nm(1:ilen)
471
472	DO 16 I=1,NmbofMol
473	Nlm=ListofMol(i)%Name
474	ilen=INDEX(Nlm,' ')-1
475	Nlm=Nlm(1:ilen)
476	C Print , Nlm,'',Nm,'*'
477	if (Nlm.EQ.Nm) then
478	C=ListofMol(I)%MCODE
479	Return
480	end if
481	16 CONTINUE
482	Write(0,*) Nm, ' is unknown molecule!'
483	Call Exit(1)
484	END
485
486
487	SUBROUTINE LireParam(Lines,N,OPT,Nu1,Nu2)
488	TYPE MOLECULES
489	SEQUENCE
490	CHARACTER*10 NAME
491	INTEGER*2 MCODE ! The code of molecule
492	INTEGER*2 NTP ! Number of data sets
493	INTEGER*2 N1(4) ! From
494	INTEGER*2 N2(4) ! TO
495	END TYPE MOLECULES
496	Type (Molecules) ListofMol(30)
497	Character*255 Lines(5),BufLine
498	Integer*2 N,I,Ilen(5),Len,TP(50)
499	Character*3 OPT
500	Character*10 Nmol
501	Character*11 Mol(30) !!!!
502	Character*20 CharTmp
503	Real*4 Nu1,Nu2,Lepremier
504	Integer*2 T_P(250,50), Popt,Pmol(5,30),Ptp(5,50)
505	Integer*2 Lnu1,Lnu2,Pmol1,Pnu1,Pnu2,Code,All_TP(250,50)
506	Integer*2 WhatMol(30),Mol_Nm(30),NumSel,NmbofMol
507	Common /Reg7/ Lepremier,NumSel,NmbofMol
508	Common /Reg8/ WhatMol,T_P,Mol_Nm
509	Common /Reg9/ ListofMol
510	Common /Reg13/Mol
511	C --------------------------------------------
512	C ---------- Insere le 26 Mai ------------------
513	DO 1 j=1,250
514	DO 1 I=1,50
515	1 ALL_TP(J,I)=0
516	DO 2 I=1,NmbofMol-1 ! without 'all'
517	if (ListofMol(I)%Name.EQ.'all') go to 2
518	N70=0
519	C ALL_TP(1)=0
520	DO 5 J=1,ListofMol(I)%NTP
521	DO 4 K=ListofMol(I)%N1(J),ListofMol(I)%N2(J)
522	N70=N70+1
523	4 ALL_TP(ListofMol(I)%MCode,N70)=K
524	5 CONTINUE
525	2 CONTINUE
526
527
528	DO 99 I=1,30
529	99 Mol(I)='***'
530	DO 10 I=1,N
531	Len=Index(Lines(i),' ')-1
532	10 Ilen(i)=Len
533	Popt=Index(Lines(1),'opt=')
534	if (Popt.EQ.0) then
535	Write(0,*) 'opt not found!'
536	Call Exit(1)
537	end if
538	i1=Popt+5
539	i2=Popt+7
540	OPT=Lines(1)(i1:i2)
541	if (OPT.NE.'lst'.AND.OPT.NE.'cal'.
542	$ AND.OPT.NE.'ltp'.AND.OPT.NE.'mco') then
543	print *, 'Invalid option !'
544	Call Exit(1)
545	end if
546	if (OPT.EQ.'lst'.OR.OPT.EQ.'mco'.OR.OPT.EQ.'ltp') Return
547	C
548	C ** TPL option **
549	if (OPT.EQ.'tpl') THEN
550	Pmol1=Index(Lines(1),'mol=')
551	if (Pmol1.EQ.0) then
552	Write(0,*) 'Option tpl : name of molecule is missed'
553	Call Exit(1)
554	end if
555	i1=Pmol1+5
556	i2=Pmol1+17
557	if (i2.GT.ILEN(1)) i2=ILEN(1)
558	C print ,i1,'',i2
559	CharTmp=Lines(1)(i1:i2)
560	i2=Index(CharTmp,'''')
561	if (i2.EQ.0) then
562	Write(0,*) 'Option tpl: quote is missed'
563	Call Exit(1)
564	end if
565	i2=i2-1
566	mol(1)=CharTmp(1:i2)
567	Return
568	end if ! OPT.EQ.'tpl'
569	C
570	C * CAL option ***
571	C Search for Nu1 and Nu2
572	K=N-1
573	If (ILEN(N).GT.4) K=N
574	C Print ,K,' ',Lines(K)
575	Pnu1=Index(Lines(K),'nu1=')
576	Lnu1=K
577	Pnu2=Index(Lines(K),'nu2=')
578	Lnu2=K
579	if (Pnu1.EQ.0.OR.Pnu2.EQ.0) then
580	Write(0,*) 'Option cal: nu1 or nu2 missed'
581	Call Exit(1)
582	end if
583	i1=Pnu1+4
584	i2=Pnu1+14
585	if (i2.GT.ILEN(Lnu1)) i2=ILEN(Lnu1)
586	CharTmp=Lines(Lnu1)(i1:i2)
587	icom=INDEX(CharTmp,',')
588	if (icom.EQ.0) then
589	Write(0,*) 'Option CAL: comma is missed after nu1'
590	Call Exit(1)
591	end if
592	CharTmp=CharTmp(1:icom-1)
593	Read(CharTmp,*,iostat=ios1) Nu1
594	CharTmp=Lines(Lnu2)(Pnu2+4:ILEN(Lnu2))
595	islesh=INDEX(CharTmp,'/')
596	if (islesh.NE.0) CharTmp=CharTmp(1:islesh-1)
597	Read(CharTmp,*,iostat=ios2) Nu2
598	if (ios1.NE.0.OR.ios2.NE.0) then
599	Write(0,*) 'Option CAL: invalid format of Nu1 or Nu2'
600	Call Exit(1)
601	end if
602	C
603	C * Search for molecules *
604	MSel=0
605	DO 11 I=1,N
606	BufLine=Lines(i)
607	6 Call SearchMol(BufLine,Nmol)
608	if (Nmol.EQ.'****') go to 11
609	Msel=Msel+1
610	Mol(Msel)=Nmol
611	If (Nmol.EQ.'all') Return
612	go to 6
613	11 Continue
614	C
615	C * Search for T_P *
616	MSel1=0
617	DO 22 I=1,N
618	BufLine=Lines(i)
619	7 Call SearchTP(BufLine,TP)
620	C Print *, '!',(TP(iq),iq=1,6)
621	if (TP(1).EQ.-1) go to 22
622	MSel1=MSel1+1
623	C ------ Trouver LeNumero de Mol --------------
624	Call CodeMol(Mol(MSel1), Code)
625	c DO 199 I2=1,NmbofMol
626	c if (Mol_Nm(I2).EQ.Code) then
627	c LeNumero=I2
628	C Print *,'!! ','Mol_Nm(',I2,')=',Mol_Nm(I2),Lenumero
629	c go to 201
630	c end if
631	c 199 CONTINUE
632
633	201 DO 202 I22=1,50
634	IF (TP(I22).EQ.0) go to 88
635	202 T_P(Code,i22)=All_TP(Code,TP(I22))
636
637	88 go to 7
638	22 CONTINUE
639	if (MSel1.EQ.0) then
640	write(0,*) 'Option CAL: tp not found!'
641	Call Exit(1)
642	end if
643	if (Msel1.NE.MSel) then
644	write(0,*) 'Option CAL: number of tp <> number of mol'
645	Call Exit(1)
646	end if
647	Return
648	End
649
650
651	Subroutine SearchMol(Line,NMol)
652	CHARACTER*255 Line
653	CHARACTER*10 NMOL
654	Character*20 CharTmp
655	Integer*2 Pmol1
656	NMOL='****'
657	C Print *, 'BLine= ',Line
658	Pmol1=Index(Line,'mol=')
659	if (Pmol1.EQ.0) Return
660	i1=Pmol1+5
661	i2=Pmol1+17
662	ilen1=INDEX(Line,' ')-1
663	if (i2.GT.ILEN1) i2=ILEN1
664	C print ,i1,'',i2
665	CharTmp=Line(i1:i2)
666	i2=Index(CharTmp,'''')
667	if (i2.EQ.0) then
668	Write(0,*) 'Option CAL : quote is missed'
669	Call Exit(1)
670	end if
671	i2=i2-1
672	C Print *, CharTmp
673	Nmol=CharTmp(1:i2)
674	C Print *, Nmol
675	Line=Line(i1+i2+1:ilen1)
676	Return
677	End
678
679	Subroutine SearchTP(Line,TP)
680	Character*255 Line,CharTmp
681	Integer*2 TP(50),PTP
682	Character*4 CHN
683	C
684	DO 14 I=1,50
685	14 TP(I)=0
686	PTP=INDEX(Line,'tp=')
687	if (PTP.EQ.0) THEN
688	TP(1)=-1
689	Return
690	end if
691	ilen1=INDEX(Line,' ')-1
692	CharTmp=Line(PTP+3:ilen1)
693	i17=INDEX(CharTmp,'mol=')
694	if (I17.EQ.0) i17=INDEX(CharTmp,'nu')
695	if (I17.EQ.0) i17=INDEX(CharTmp,' ')-1
696	if (CharTmp(i17:i17).EQ.',') then
697	i17=i17-1
698	else
699	i17=i17-2
700	end if
701	CharTmp=CharTmp(1:i17)
702	C Print *, CharTmp
703	Line=Line(PTP+3+i17:ilen1)
704	C Print *, Line
705	C => from cross_u.f
706	jjj=1
707	if (CharTmp(1:1).EQ.'0') then
708	TP(1)=0
709	go to 600
710	end if
711	ilen=INDEX(CharTmp,' ')-1
712	333 icomma=INDEX(CharTmp,',')
713	if (icomma.eq.0) then
714	CHN=CharTmp(1:ilen)
715	READ(CHN,'(I3)',IOSTAT= ios) ntpcode
716	if (ios.NE.0) go to 500
717	TP(jjj)=ntpcode
718	else
719	CHN=CharTmp(1:icomma-1)
720	READ(CHN,'(I3)',IOSTAT=ios,ERR=500) ntpcode
721	if (ios.NE.0) go to 500
722	TP(jjj)=ntpcode
723	jjj=jjj+1
724	CharTmp=CharTmp(icomma+1:ilen)
725	ilen=ilen-icomma
726	go to 333
727
728	end if
729	GO TO 600
730	500 PRINT *, 'Option CAL: TP format is invalid!'
731	Call Exit(1)
732	c 600 Print *, '!!',(TP(i),i=1,6)
733	600 Return
734	End
735
736	Subroutine MCodes
737	CHARACTER*10 MName
738	Character*3 Mcd
739	Character*180 Path1
740	Common /Reg12/Path1
741	ilen1=INDEX(Path1,' ')-1
742	OPEN(17,file=Path1(1:ilen1)//'molec.dat',Status='OLD',
743	$ERR=90,iostat=ios )
744	1 Read(17,'(A10,A3)',end=88) MName,Mcd
745	C hcfc-225cb
746	if (MName.EQ.'all ') go to 1
747	Write(6,'(A10,2X,A3)') Mname,Mcd
748	go to 1
749	88 close(17)
750	Return
751	90 if (ios.EQ.6) Write(0,*) 'File molec.dat not found!'
752	Call Exit(1)
753	end
754
755	Subroutine List_TP
756	Character*30 TPL
757	Character*180 Path1
758	Common /Reg12/Path1
759	ilen1=INDEX(Path1,' ')-1
760	OPEN(17,file=Path1(1:ilen1)//'nmb.dat',Status='OLD',
761	$Err=90,iostat=ios )
762	1 Read(17,'(A30)',end=40) TPL
763	Write(6,'(A30)') TPL
764	go to 1
765	40 close(17)
766	Return
767	90 if (ios.EQ.6) Write(0,*) 'File nmb.dat not found!'
768	Call Exit(1)
769	End
770
771
772
773	Subroutine MolCodes
774
775	TYPE MOLECULES
776	SEQUENCE
777	CHARACTER*10 NAME
778	INTEGER*2 MCODE ! The code of molecule
779	INTEGER*2 NTP ! Number of data sets
780	INTEGER*2 N1(4) ! From
781	INTEGER*2 N2(4) ! TO
782	END TYPE MOLECULES
783	Type CONDITIONS
784	SEQUENCE
785	REAL*4 Temperature
786	REAL*4 Pressure
787	REAL*4 Resolution
788	END TYPE CONDITIONS
789	TYPE (CONDITIONS) AllCondit(200)
790	TYPE (MOLECULES) ListofMol(30)
791	Integer*2 NumSel,NmbofMol,All_TP(50)
792	Real*4 Lepremier,WvMin,WvMax,Step
793	Character*80 SFORM
794	Character*3 SN
795	Character*5 S5
796	Character*16 TPCHAR(200)
797	Character*180 Path1
798	Common /Reg9/ ListofMol
799	Common /Reg7/ Lepremier,NumSel,NmbofMol
800	COMMON /REG4/ WvMin,WvMax,Step
801	Common /Reg11/ AllCondit
802	Common /Reg12/Path1
803	ilen1=INDEX(Path1,' ')-1
804	OPEN(17,file=Path1(1:ilen1)//'nmb.dat',Status='OLD')
805	INN=1
806	18 Read(17,'(A5,A14)',end=19) S5,TPCHAR(INN)
807	INN=INN+1
808	go to 18
809	19 INN=INN-1
810	Close(17)
811	DO 1 I=1,50
812	1 ALL_TP(I)=0
813	C Print *, WvMin,' ',WvMax
814	Write(6,'(F9.3,1x,F9.3)') WvMin,WvMax
815	C Print *,'Nmol=',NmbofMol
816	DO 2 I=1,NmbofMol-1 ! without 'all'
817	if (ListofMol(I)%Name.EQ.'all') go to 2
818	N=0
819	C ALL_TP(1)=0
820	DO 5 J=1,ListofMol(I)%NTP
821	DO 4 K=ListofMol(I)%N1(J),ListofMol(I)%N2(J)
822	N=N+1
823	4 ALL_TP(N)=K
824	5 CONTINUE
825	Write(6,*) ListofMol(I)%Name,' ',
826	$ (TPCHAR(ALL_TP(JJ)),jj=1,N)
827	2 Continue
828	Return
829	End
830
831
832
833

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format