C CROSS SECTIONS DATA BASE MANAGEMENT PROGRAM C ** VERSION 2.6 for INTERNET ** C ** 16 June 1998 ** C CHARACTER*180 LINE, Path, Path1 CHARACTER*255 FMol, Lines(10),LinesCom Character*27 Str ! 27 for UNIX CHARACTER*40 B_Name CHARACTER*30 Idx_Name CHARACTER*255 Extr_Name,Extr_Idx CHARACTER*3 CHN,StCode CHARACTER*10 S10 INTEGER(2) NmbMol, LeNumerodeMol, MaxMol, NtpCode, ilen,MaxLine Integer*4 NmIdx,NmLines,NmNewLines,NuLn,Ndc,ExtLn REAL*4 LowerWn, UpperWn, FromWv, ToWv,Step, Lepremier,Nu1,Nu2 INTEGER(2) NLines1 TYPE MOLECULES SEQUENCE CHARACTER*10 NAME INTEGER(2) MCODE ! The code of molecule INTEGER(2) NTP ! Number of data sets INTEGER(2) N1(4) ! From INTEGER(2) N2(4) ! TO END TYPE MOLECULES Type CONDITIONS SEQUENCE REAL*4 Temperature REAL*4 Pressure REAL*4 Resolution END TYPE CONDITIONS TYPE (MOLECULES) ListofMol(30) TYPE (CONDITIONS) AllCondit(200) INTEGER*4 I,J,K, N1(4),N2(4),RR Integer(2) WhatMol(30), WhatTemp(10),Code,jjj, T_P(250,50) Integer(2) Mol_Nm(30),NumSel,LeNumero,NmbofMol,NTP(30) Integer(2) MCode1 CHARACTER*10 Name, WAIT Character*10 MolecName Integer*4 Idx(2500),Idx1(2500) CHARACTER*3 OPT CHARACTER*11 MOL(30) !!!! COMMON /REG1/ RR,MaxLine,NmLines,NmIdx,jjj, Code, WhatTemp COMMON /REG2/ Idx COMMON /REG3/ B_Name,Path COMMON /REG4/ LowerWn,UpperWn,Step Common /REG5/ NuLn,Ndc,ExtLn Common /Reg6/ Idx1 Common /Reg7/ Lepremier,NumSel,NmbofMol Common /Reg8/ WhatMol,T_P,Mol_Nm Common /Reg9/ ListofMol C Common /Reg10/ LowerWn, UpperWn Common /Reg11/ AllCondit Common /Reg12/ Path1 Common /Reg13/ Mol C ************************************************************ C MAIN PROGRAM C ******** **************************************************** C recl mini=200*16(TPCHAR)+10(NAME)+5(MCODE) pour Subroutine MolCodes open(unit=6,file='/dev/stdout',recl=3215) RR=27 ! 27 for the UNIX version! MaxLine=1150 ! Max number of records contained in a block to be extracted Step=2.0 ! Step for indexation C SCommand='clear' ! clear for UNIX NuLn=0 Ndc=3 c CALL System(SCommand) c Call LaPremiere c Call System(SCommand) Path='' Path1='/usr/local/datageisa/crs97/' ilen=Index(Path,' ')-1 ilen1=Index(Path1,' ')-1 FMol= Path1(1:ilen1)//'molec.dat' OPEN(10,FILE=FMol,STATUS='OLD', ERR=8888,iostat=iosml) OPEN(11,FILE=Path1(1:ilen1)//'numbers.dat', $FORM='FORMATTED',STATUS='OLD',ERR=8888,iostat=iosnm) C *** Name of the data file and its index file *** B_Name='/usr/local/datageisa/data/cross_97.asc' Idx_Name='cross97.idx' DO 1666 I20=1,250 DO 1666 J20=1,50 1666 T_P(I20,J20)=0 DO 1667 I20=1,30 C NTP(I20)=0 1667 Mol(I20)='***' C READ OF THE PROGRAM PARAMETERS NmbofMol=1 1 READ(10,'(A10,I3,1X,I2,8I3)', IOSTAT=ios,END=2) $Name, Code,I,N1(1),N2(1),N1(2),N2(2),N1(3),N2(3), $N1(4),N2(4) ListofMol(NmbofMol)%Name=Name ListofMol(NmbofMol)%MCode=Code ListofMol(NmbofMol)%NTP=I Mol_Nm(NmbofMol)=Code DO 40 J=1,I ListofMol(NmbofMol)%N1(j)=N1(j) 40 ListofMol(NmbofMol)%N2(j)=N2(j) NmbofMol=NmbofMol+1 GO TO 1 C NmbofMol=NmbofMol-1 ! Attention !!! 2 Close(10) I=1 3 READ(11,'(I3,2X,F5.1,F12.2,8X,F6.4)',END=7) J, $AllCondit(I)%Temperature, AllCondit(I)%Pressure, $AllCondit(I)%Resolution i=i+1 GO TO 3 c 5 CLOSE(11) C **** READ OF THE INPUT PARAMETERS ************* c NLines1=1 7 READ (*,'(A255)',end=334) LinesCom !1st line if (Nlines1.EQ.0) Nlines1=1 Lines(NLines1)=LinesCom ill=INDEX(LinesCom,' ')-1 DO 333 i34=1,ill 333 if (LinesCom(i34:i34).EQ.'/') go to 334 C Print *, Nlines1,'&',Lines(NLines1) NLines1=NLines1+1 if (NLINES.GT.10) then Write(0,*) 'Too many input lines (it has to be <=10)' ii=1 Call Exit(ii) end if go to 7 C ______________________________________________________ 334 Call LireParam(Lines,NLines1,OPT,Nu1,Nu2) C Print *,'!! ',Mol(1),'&',Mol(2),'&',Mol(3) C Print *, '*************** GEISA CROSS-97 ***************' C Print *, ' ' C Print *,' The input parameters ' C Print *, ' ' C Print *, 'OPT=',opt C if (OPT.NE.'cal') go to 335 c C Print *, 'The selected molecules and (T,P) codes: ' C DO 188 I20=1, NmbofMol-1 !without 'all' c if (Mol(i20).NE.'***') then c Call CodeMol(Mol(I20),MCode1) c else c go to 335 c end if c c DO 1888 J20=1,NmbofMol cc c if (MCode1.EQ.Mol_Nm(J20)) then c LN=0 c DO 999 k20=1,50 c 999 if (T_P(J20,K20).NE.0) LN=LN+1 c if (LN.EQ.0) LN=1 c Print *,Mol(i20),': ',(T_P(J20,KK),KK=1,LN) c go to 188c c end if c 1888 Continue c 188 Continue c 335 Print *,'**********************************************' if (OPT.EQ.'lst') go to 602 if (OPT.EQ.'mco') then Call MCodes ii=0 Call Exit(ii) end if if (OPT.EQ.'ltp') then Call List_TP ii=0 Call Exit(ii) end if NumSel=0 FromWv=Nu1 ToWv=Nu2 Nglob=0 if (Mol(1).EQ.'all') then Code=0 ! Select all the data available jjj=1 WhatTemp(1)=0 go to 602 end if 338 NumSel=NumSel+1 if (Mol(NumSel).EQ.'***') then NumSel=NumSel-1 go to 602 end if Call CodeMol(Mol(NumSel),Code) WhatMol(NumSel)=Code go to 338 602 ilen=INDEX(Path,' ')-1 OPEN(60,File=Path(1:ilen)//B_Name, $ Status='OLD',Form='UNFORMATTED',Access='DIRECT',Recl=RR, $ Err=8888, iostat=iosban) OPEN(66,File=Path1(1:ilen1)//Idx_Name,Status='Old', $ Err=8888, iostat=iosidx) Read(66,'(I10)') NmIdx ! Number of index file components Read(66,'(I10)') NmLines ! Number of the data bank entries DO 499 i=1,NmIdx-2 Read(66,'(I10)') Idx(i) c Write(6,*)'Idx(',i,')=',Idx(i) 499 Continue Close(66) Read(60,Rec=1) Str S10=Str(1:10) Read(S10,'(F10.6)') LowerWn Read(60,Rec=NmLines) Str S10=Str(1:10) Read(S10,'(F10.6)') UpperWn Close(60) if (OPT.EQ.'lst') then Call MolCodes ii=0 Call Exit(ii) end if Extr_Name=Path1(1:ilen1)//'cross97.zzz' Call Extraction(FromWv,ToWv,Extr_Name) C Call System('cat '//Extr_Name) 9999 ii=0 Call Exit(ii) 8888 if (iosml.EQ.6) Write(0,*) 'File molec.dat not found!' if (iosnm.EQ.6) Write(0,*) 'File numbers.dat not found!' if (iosban.EQ.6) Write(0,*) 'CRS data bank not found!' if (iosidx.EQ.6) Write(0,*) 'Index file cross97.idx not found!' Write(0,*) 'The program is stoped' ii=1 Call Exit(ii) END c ** Subroutines ** c SUBROUTINE Extraction(From,to1,Out) Real*4 From,to1,LePremier Real*4 Freq,LowerWn,UpperWn,Step Integer(2) MaxLine,jjj,code,MCode,TPCode,WhatTemp(10),WhatMol(30) Integer(2) Mol_Nm(30),NumSel,LeNumero,NmbofMol,T_P(250,50) Integer*4 NmIdx,NmLines, BlockLen,ExtLn,NRec,RR,Idx(2500) Integer*4 NFact,Ninit,Irec,InitRec,NuLn,Ndc, MolLn(250) Character*40 B_Name Character*30 Idx_File Character*3 S3 Character*10 S10 Character*11 Mol(30) !!!! CHARACTER*180 Path,out1 Character*255 Out Integer(2) OutUnit Character*27 Lines(1150),ExtLines(1150),Str,Line ! 27 for UNIX COMMON /REG1/ RR,MaxLine,NmLines,NmIdx,jjj, Code, WhatTemp COMMON /REG2/ Idx Common /REG3/ B_Name,Path Common /REG4/ LowerWn,UpperWn,Step Common /Reg5/ Nuln,Ndc,ExtLn Common /REG7/ LePremier, NumSel,NmbofMol Common /Reg8/ WhatMol, T_P ,Mol_Nm Common /REG13/MOL c n100=Int((From-LowerWn)/Step)+1 OutUnit=1 ! Set up output unit c ilen=INDEX(Out,'.') c if (ilen.NE.0) Idx_File=Out(1:ilen)//'idx' c if (ilen.EQ.0) then c ilen=INDEX(Out,' ')-1 c Idx_File=Out(1:ilen)//'.idx' c end if n100=(Int(From)-Int(LowerWn))/Int(step)+1 n200=(Int(to1)-Int(LowerWn))/Int(step)+2 if (N100.GT.NmIdx-2) N100=NmIdx-2 if (N100.LT.1) N100=1 if (N200.GT.NmIdx-2) N200=NmIdx-2 if (N200.LT.1) N200=1 NInit=Idx(n100) DO 3131 I=1,250 3131 MolLn(i)=0 C NFact=NmLines-NInit+1 ! old !! NFact=Idx(n200)-NInit+1 if (NFact.LE.MaxLine) BlockLen=NFact if (NFact.GT.MaxLine) BlockLen=MaxLine ilen=INDEX(Path,' ')-1 OPEN(60,File=Path(1:ilen)//B_Name, $ Status='OLD',Form='UNFORMATTED',Access='Direct', $Recl=BlockLen*rr,Err=888) OPEN(Unit=OutUnit,Form='UNFORMATTED', $ ACCESS='Direct', $Status='UNKNOWN',Recl=MaxLine*rr) N=NFact/BlockLen NN=MOD(NFact,BlockLen) ExtLn=0 IFact=0 Irec=1 InitRec =NInit/BlockLen+1 c Print *, 'Scaning the data base from the entry N ', Ninit c *** Block-by-block reading the data file *** c DO 1150 i=1,N Read(60,Rec=InitRec) Lines InitRec=InitRec+1 DO 101 j=1,BlockLen S10=Lines(j)(1:10) Read(S10,'(F10.6)')Freq if (Freq.GT.to1) go to 1250 if (Freq.LT.From) go to 101 if (Code.EQ.0) go to 105 S3=Lines(j)(21:23) Read(S3,'(I3)') MCode DO 277 I20=1,NumSel if (MCode.EQ.WhatMol(i20)) go to 191 ! was: 115 277 CONTINUE go to 101 C 115 DO 188 I20=1, NmbofMol c if (MCode.EQ.Mol_Nm(I20)) then c LeNumero=I20 c go to 191 c end if c 188 Continue 191 if (T_P(MCode,1).EQ.0) go to 105 S3=Lines(j)(24:26) Read(S3,'(I3)') TPCode C if (MCode.NE.Code) go to 109 C C 111 if (Freq.GT.to1) go to 1250 C if (Freq.LT.From) go to 101 DO 103 jj=1,50 if (T_P(MCode,jj).EQ.0) go to 101 103 if (T_P(MCode,jj).EQ.TPCode) go to 105 114 go to 101 105 ExtLn=ExtLn+1 MolLn(Mcode)=MolLn(MCode)+1 IFact=IFact+1 ExtLines(IFact)=Lines(j) if (ExtLn.EQ.1) LePremier=Freq C Call Index1(Idx_File,1,Freq,Step) C if (Mod(ExtLn,200).EQ.0) Print *, ExtLn, ' lines rewritten' if (IFACT.GE.BlockLen) then Write(OutUnit,Rec=IRec) ExtLines IRec=Irec+1 IFact=0 End if C 109 if (Freq.GT.to1) go to 1250 101 Continue 1150 Continue 1250 Continue C INQUIRE(unit=OutUnit,name=out1) c Call System('cat '//out1) Close(OutUnit) Open(Unit=OutUnit,File='fort.1',Status='Old', $Form='UNFORMATTED',ACCESS='DIRECT',Recl=rr) IREC=(IREC-1)*BlockLen+1 if (N.NE.0) then DO 1212 i=1,IFact Write(OutUnit,Rec=Irec) ExtLines(i) C Write(6,'(A26)') ExtLines(i)(1:26) !(1:27) for PC 1212 Irec=Irec+1 end if Close(60) C if (Freq.GT.to1) go to 1213 !!! suprimer le 29 mai 1998 cc ** Line-by-line reading the data bank file ** OPEN(60,File=Path(1:ilen)//B_Name, $ Status='OLD',Form='UNFORMATTED',Access='DIRECT',Recl=rr, $Err=888) InitRec=(InitRec-1)*BlockLen+1 DO 777 i=1,nn READ(60,Rec=InitRec) Line cc ------------------------------------------------------------------ InitRec=InitRec+1 S3=Line(21:23) Read(S3,'(I3)') MCode S3=Line(24:26) Read(S3,'(I3)') TPCode S10=Line(1:10) Read(S10,'(F10.6)') Freq if (Code.EQ.0) go to 177 C if (MCode.NE.Code) go to 777 DO 377 I20=1,NumSel if (MCode.EQ.WhatMol(i20)) go to 177 377 CONTINUE Go to 777 177 if (Freq.GT.to1) go to 1213 if (Freq.LT.From) go to 777 c DO 1888 I20=1, NmbofMol c if (MCode.EQ.Mol_Nm(I20)) then c LeNumero=I20 c go to 991 c end if c1888 Continue 991 if (T_P(MCode,1).EQ.0) go to 106 DO 104 jj=1,50 if (T_P(MCode,jj).EQ.0) go to 666 104 if (T_P(MCode,jj).EQ.TPCode) go to 106 666 go to 777 106 ExtLn=ExtLn+1 If (ExtLn.EQ.1) then LePremier=Freq MolLn(MCode)=MolLn(MCode)+1 C Call INDEX1(Idx_File,1,Freq,Step) C if (Mod(ExtLn,200).EQ.0) Print *, ExtLn, ' lines rewritten' Write(OutUnit,Rec=IRec) Line C Write(6,'(A26)') Line(1:26) ! 26 for Unix, 27 -for PC IREC=IREC+1 777 Continue cc -------------------------------------------------------------------- 1213 Close(OutUnit) Write(6,*) 'Selected molecules: ' DO 1188 I20=1, NmbofMol-1 !without 'all' if (Mol(1).EQ.'all') then Write(6,*) 'All molecules have been selected' go to 1189 end if if (Mol(i20).NE.'***') then Call CodeMol(Mol(i20),mcode) C Print *,Mol(i20),' ', MolLn(mcode),' lines rewritten' write(*,'(A10,1X,I8,A17)') $ Mol(i20),MolLn(mcode),' lines rewritten' end if 1188 Continue 1189 Write(*,7890) 'Spectral range: ', from,' - ',to1 Write(6,*) 'Total: ',ExtLn, ' lines rewritten' C if (ExtLn.NE.0) Call Index1(Idx_File,0,0.0,Step) RETURN 888 Write(0,*) 'File opening error : ',B_Name 7890 FORMAT(A16,F10.3,A3,F10.3) ii=1 Call Exit(ii) END SUBROUTINE INDEX1(Nm_Idx,Last,Freq,Step) Real*4 Freq,CurrF,Step,LePremier Integer*4 Idx1(2500),NuLn,Ndc,ExtLn Character*30 Nm_Idx Common /Reg5/ Nuln,Ndc,ExtLn Common /Reg6/Idx1 Common /Reg7/ CurrF If (Last.EQ.0) then Idx1(1)=Ndc ! Total length of *.idx file Idx1(2)=ExtLn ! Number of entries in the data bank Idx1(3)=1 ! OPEN(33,File=Nm_Idx,Status='UNKNOWN') DO 30 i=1,Ndc Write(33,'(I10)') Idx1(i) 30 CONTINUE Close(33) Return end if MaxIdx=2500 NuLn=Nuln+1 if (Int(Freq).GE.Int(CurrF+Step)) then n1=(Int(Freq)-Int(CurrF))/Int(Step) do 22 i=0,nl ndc=ndc+1 if (ndc.gt.MaxIdx) then Write(0,*) 'Can not index this file!' ii=1 Call Exit(ii) end if NuLn1=NuLn if (NuLn1.LT.1) NuLn1=Nuln Idx1(Ndc)=NuLn1 22 CurrF=CurrF+Step end if Return End SUBROUTINE CodeMol(Nm,C) TYPE MOLECULES SEQUENCE CHARACTER*10 NAME INTEGER(2) MCODE ! The code of molecule INTEGER(2) NTP ! Number of data sets INTEGER(2) N1(4) ! From INTEGER(2) N2(4) ! TO END TYPE MOLECULES CHARACTER*11 Nm, Nlm !!!! Integer(2) C, NmbofMol,NumSel Type (Molecules) ListofMol(30) Real*4 LePremier Common /REG9/ ListofMol Common /Reg7/ Lepremier,NumSel,NmbofMol ilen=INDEX(Nm,' ')-1 Nm=Nm(1:ilen) DO 16 I=1,NmbofMol Nlm=ListofMol(i)%Name ilen=INDEX(Nlm,' ')-1 Nlm=Nlm(1:ilen) C Print *, Nlm,'*',Nm,'*' if (Nlm.EQ.Nm) then C=ListofMol(I)%MCODE Return end if 16 CONTINUE Write(0,*) Nm, ' is unknown molecule!' ii=1 Call Exit(ii) END SUBROUTINE LireParam(Lines,N,OPT,Nu1,Nu2) TYPE MOLECULES SEQUENCE CHARACTER*10 NAME INTEGER(2) MCODE ! The code of molecule INTEGER(2) NTP ! Number of data sets INTEGER(2) N1(4) ! From INTEGER(2) N2(4) ! TO END TYPE MOLECULES Type (Molecules) ListofMol(30) Character*255 Lines(5),BufLine Integer(2) N,I,Ilen(5),Len,TP(50) Character*3 OPT Character*10 Nmol Character*11 Mol(30) !!!! Character*20 CharTmp Real*4 Nu1,Nu2,Lepremier Integer(2) T_P(250,50), Popt,Pmol(5,30),Ptp(5,50) Integer(2) Lnu1,Lnu2,Pmol1,Pnu1,Pnu2,Code,All_TP(250,50) Integer(2) WhatMol(30),Mol_Nm(30),NumSel,NmbofMol Common /Reg7/ Lepremier,NumSel,NmbofMol Common /Reg8/ WhatMol,T_P,Mol_Nm Common /Reg9/ ListofMol Common /Reg13/Mol C -------------------------------------------- C ---------- Insere le 26 Mai ------------------ DO 1 j=1,250 DO 1 I=1,50 1 ALL_TP(J,I)=0 DO 2 I=1,NmbofMol-1 ! without 'all' if (ListofMol(I)%Name.EQ.'all') go to 2 N70=0 C ALL_TP(1)=0 DO 5 J=1,ListofMol(I)%NTP DO 4 K=ListofMol(I)%N1(J),ListofMol(I)%N2(J) N70=N70+1 4 ALL_TP(ListofMol(I)%MCode,N70)=K 5 CONTINUE 2 CONTINUE DO 99 I=1,30 99 Mol(I)='***' DO 10 I=1,N Len=Index(Lines(i),' ')-1 10 Ilen(i)=Len Popt=Index(Lines(1),'opt=') if (Popt.EQ.0) then Write(0,*) 'opt not found!' ii=1 Call Exit(ii) end if i1=Popt+5 i2=Popt+7 OPT=Lines(1)(i1:i2) if (OPT.NE.'lst'.AND.OPT.NE.'cal'. $ AND.OPT.NE.'ltp'.AND.OPT.NE.'mco') then Write(0,*) 'Invalid option !' ii=1 Call Exit(ii) end if if (OPT.EQ.'lst'.OR.OPT.EQ.'mco'.OR.OPT.EQ.'ltp') Return C C **** TPL option **** if (OPT.EQ.'tpl') THEN Pmol1=Index(Lines(1),'mol=') if (Pmol1.EQ.0) then Write(0,*) 'Option tpl : name of molecule is missed' ii=1 Call Exit(ii) end if i1=Pmol1+5 i2=Pmol1+17 if (i2.GT.ILEN(1)) i2=ILEN(1) C print *,i1,'*',i2 CharTmp=Lines(1)(i1:i2) i2=Index(CharTmp,'''') if (i2.EQ.0) then Write(0,*) 'Option tpl: quote is missed' ii=1 Call Exit(ii) end if i2=i2-1 mol(1)=CharTmp(1:i2) Return end if ! OPT.EQ.'tpl' C C *** CAL option ***** C Search for Nu1 and Nu2 K=N-1 If (ILEN(N).GT.4) K=N C Print *,K,' * ',Lines(K) Pnu1=Index(Lines(K),'nu1=') Lnu1=K Pnu2=Index(Lines(K),'nu2=') Lnu2=K if (Pnu1.EQ.0.OR.Pnu2.EQ.0) then Write(0,*) 'Option cal: nu1 or nu2 missed' ii=1 Call Exit(ii) end if i1=Pnu1+4 i2=Pnu1+14 if (i2.GT.ILEN(Lnu1)) i2=ILEN(Lnu1) CharTmp=Lines(Lnu1)(i1:i2) icom=INDEX(CharTmp,',') if (icom.EQ.0) then Write(0,*) 'Option CAL: comma is missed after nu1' ii=1 Call Exit(ii) end if CharTmp=CharTmp(1:icom-1) Read(CharTmp,*,iostat=ios1) Nu1 CharTmp=Lines(Lnu2)(Pnu2+4:ILEN(Lnu2)) islesh=INDEX(CharTmp,'/') if (islesh.NE.0) CharTmp=CharTmp(1:islesh-1) Read(CharTmp,*,iostat=ios2) Nu2 if (ios1.NE.0.OR.ios2.NE.0) then Write(0,*) 'Option CAL: invalid format of Nu1 or Nu2' ii=1 Call Exit(ii) end if C C *** Search for molecules *** MSel=0 DO 11 I=1,N BufLine=Lines(i) 6 Call SearchMol(BufLine,Nmol) if (Nmol.EQ.'****') go to 11 Msel=Msel+1 Mol(Msel)=Nmol If (Nmol.EQ.'all') Return go to 6 11 Continue C C *** Search for T_P *** MSel1=0 DO 22 I=1,N BufLine=Lines(i) 7 Call SearchTP(BufLine,TP) C Print *, '!',(TP(iq),iq=1,6) if (TP(1).EQ.-1) go to 22 MSel1=MSel1+1 C *------ Trouver LeNumero de Mol --------------* Call CodeMol(Mol(MSel1), Code) c DO 199 I2=1,NmbofMol c if (Mol_Nm(I2).EQ.Code) then c LeNumero=I2 C Print *,'!! ','Mol_Nm(',I2,')=',Mol_Nm(I2),Lenumero c go to 201 c end if c 199 CONTINUE 201 DO 202 I22=1,50 IF (TP(I22).EQ.0) go to 88 202 T_P(Code,i22)=All_TP(Code,TP(I22)) 88 go to 7 22 CONTINUE if (MSel1.EQ.0) then write(0,*) 'Option CAL: tp not found!' ii=1 Call Exit(ii) end if if (Msel1.NE.MSel) then write(0,*) 'Option CAL: number of tp <> number of mol' ii=1 Call Exit(ii) end if Return End Subroutine SearchMol(Line,NMol) CHARACTER*255 Line CHARACTER*10 NMOL Character*20 CharTmp Integer(2) Pmol1 NMOL='****' C Print *, 'BLine= ',Line Pmol1=Index(Line,'mol=') if (Pmol1.EQ.0) Return i1=Pmol1+5 i2=Pmol1+17 ilen1=INDEX(Line,' ')-1 if (i2.GT.ILEN1) i2=ILEN1 C print *,i1,'*',i2 CharTmp=Line(i1:i2) i2=Index(CharTmp,'''') if (i2.EQ.0) then Write(0,*) 'Option CAL : quote is missed' ii=1 Call Exit(ii) end if i2=i2-1 C Print *, CharTmp Nmol=CharTmp(1:i2) C Print *, Nmol Line=Line(i1+i2+1:ilen1) Return End Subroutine SearchTP(Line,TP) Character*255 Line,CharTmp Integer(2) TP(50),PTP Character*4 CHN C DO 14 I=1,50 14 TP(I)=0 PTP=INDEX(Line,'tp=') if (PTP.EQ.0) THEN TP(1)=-1 Return end if ilen1=INDEX(Line,' ')-1 CharTmp=Line(PTP+3:ilen1) i17=INDEX(CharTmp,'mol=') if (I17.EQ.0) i17=INDEX(CharTmp,'nu') if (I17.EQ.0) i17=INDEX(CharTmp,' ')-1 if (CharTmp(i17:i17).EQ.',') then i17=i17-1 else i17=i17-2 end if CharTmp=CharTmp(1:i17) C Print *, CharTmp Line=Line(PTP+3+i17:ilen1) C Print *, Line C => from cross_u.f jjj=1 if (CharTmp(1:1).EQ.'0') then TP(1)=0 go to 600 end if ilen=INDEX(CharTmp,' ')-1 333 icomma=INDEX(CharTmp,',') if (icomma.eq.0) then CHN=CharTmp(1:ilen) READ(CHN,'(I3)',IOSTAT= ios) ntpcode if (ios.NE.0) go to 500 TP(jjj)=ntpcode else CHN=CharTmp(1:icomma-1) READ(CHN,'(I3)',IOSTAT=ios,ERR=500) ntpcode if (ios.NE.0) go to 500 TP(jjj)=ntpcode jjj=jjj+1 CharTmp=CharTmp(icomma+1:ilen) ilen=ilen-icomma go to 333 end if GO TO 600 500 Write(0, *) 'Option CAL: TP format is invalid!' ii=1 Call Exit(ii) C 600 Print *, '!!',(TP(i),i=1,6) 600 Return End Subroutine MCodes CHARACTER*10 MName Character*3 Mcd Character*180 Path1 Common /Reg12/Path1 ilen1=INDEX(Path1,' ')-1 OPEN(17,file=Path1(1:ilen1)//'molec.dat',Status='OLD', $ERR=90,iostat=ios ) 1 Read(17,'(A10,A3)',end=88) MName,Mcd C hcfc-225cb if (MName.EQ.'all ') go to 1 Write(6,'(A10,2X,A3)') Mname,Mcd go to 1 88 close(17) Return 90 if (ios.EQ.6) Write(0,*) 'File molec.dat not found!' ii=1 Call Exit(ii) end Subroutine List_TP Character*30 TPL Character*180 Path1 Common /Reg12/Path1 ilen1=INDEX(Path1,' ')-1 OPEN(17,file=Path1(1:ilen1)//'nmb.dat',Status='OLD', $Err=90,iostat=ios ) 1 Read(17,'(A30)',end=40) TPL Write(6,'(A30)') TPL go to 1 40 close(17) Return 90 if (ios.EQ.6) Write(0,*) 'File nmb.dat not found!' ii=1 Call Exit(ii) End Subroutine MolCodes TYPE MOLECULES SEQUENCE CHARACTER*10 NAME INTEGER(2) MCODE ! The code of molecule INTEGER(2) NTP ! Number of data sets INTEGER(2) N1(4) ! From INTEGER(2) N2(4) ! TO END TYPE MOLECULES Type CONDITIONS SEQUENCE REAL*4 Temperature REAL*4 Pressure REAL*4 Resolution END TYPE CONDITIONS TYPE (CONDITIONS) AllCondit(200) TYPE (MOLECULES) ListofMol(30) Integer(2) NumSel,NmbofMol,All_TP(50) Real*4 Lepremier,WvMin,WvMax,Step Character*80 SFORM Character*3 SN Character*5 S5 Character*16 TPCHAR(200) Character*180 Path1 Common /Reg9/ ListofMol Common /Reg7/ Lepremier,NumSel,NmbofMol COMMON /REG4/ WvMin,WvMax,Step Common /Reg11/ AllCondit Common /Reg12/Path1 ilen1=INDEX(Path1,' ')-1 OPEN(17,file=Path1(1:ilen1)//'nmb.dat',Status='OLD') INN=1 18 Read(17,'(A5,A14)',end=19) S5,TPCHAR(INN) INN=INN+1 go to 18 19 INN=INN-1 Close(17) DO 1 I=1,50 1 ALL_TP(I)=0 C Print *, WvMin,' ',WvMax Write(6,'(F9.3,1x,F9.3)') WvMin,WvMax C Print *,'Nmol=',NmbofMol DO 2 I=1,NmbofMol-1 ! without 'all' if (ListofMol(I)%Name.EQ.'all') go to 2 N=0 C ALL_TP(1)=0 DO 5 J=1,ListofMol(I)%NTP DO 4 K=ListofMol(I)%N1(J),ListofMol(I)%N2(J) N=N+1 4 ALL_TP(N)=K 5 CONTINUE Write(6,*) ListofMol(I)%Name,' ',ListofMol(i)%Mcode,' ', $ (TPCHAR(ALL_TP(JJ)),jj=1,N) 2 Continue Return End