Context Navigation

source: trunk/crs97/araf2/cross97.f @ 1

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

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

Download in other formats: