Context Navigation

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

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

Download in other formats: