Context Navigation

source: trunk/crs97/cross97z_org.f @ 1

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

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

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

Download in other formats: