1 | C CE PROGRAMME CREE UN SOUS-FICHIER DE LA BANQUE DANS LA MEME |
---|
2 | C STRUCTURE,C'EST-A-DIRE EXPLOITABLE PAR LE PROGRAMME *** GEISA *** |
---|
3 | C |
---|
4 | C LA COPIE SE FAIT SUR L'UNITE LOGIQUE 2 |
---|
5 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * |
---|
6 | C |
---|
7 | C MODIF : 06.05.1991 PASSAGE DE 40 A 75 MOLECULES DANS LES COMMON |
---|
8 | C |
---|
9 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * |
---|
10 | subroutine copie(v,*) |
---|
11 | C |
---|
12 | character*4 blanc |
---|
13 | character*3 pgm,ianl,iext,itrs,ilst,icop,info,icre,mpgx, |
---|
14 | & liste,oui |
---|
15 | integer vers |
---|
16 | logical*1 qqq |
---|
17 | real nu1,nu2 |
---|
18 | real v(1) |
---|
19 | C |
---|
20 | common/p1/ nu1,nu2,dnu,nbclas,khist,kanal,vers,mode,liste |
---|
21 | common/p3/ imole,iran,ival,pgm,ianl,iext,itrs,ilst,icop,info,icre |
---|
22 | common/p8/ npgx,nfff,mpgx,qqq(75) |
---|
23 | common/entsor/iuni,juni,kuni,ient,isor,iper,nresv,maxx,blanc,oui |
---|
24 | C |
---|
25 | data izero,zero/0,0./ |
---|
26 | C INITIALISATION DE L'UNITE LOGIQUE DE LECTURE DE LA BANQUE |
---|
27 | call pgeisa(0.,99999.,*130) |
---|
28 | c |
---|
29 | C OUVERTURE DU FICHIER KUNI |
---|
30 | open(unit=kuni,status='new',access='direct',recl=11276) |
---|
31 | C |
---|
32 | C IMPRESSION DU TITRE |
---|
33 | C |
---|
34 | C &'* GEISA GEISA *'/' * GEISA *',98X,'* GEISA *'/ |
---|
35 | C WRITE(ISOR,900 ) VERS,NU1,NU2 |
---|
36 | write(isor,900 ) vers,pgm,pgm,nu1,nu2 |
---|
37 | 900 format(1x,17('*'),98x,17('*')/1x,'* geisa geisa *', |
---|
38 | &30x,'creation d''un sous-fichier de GEISA',i2.2,31x, |
---|
39 | &'* geisa geisa *'/' *',6x,a3,6x,'*',98x,'*',6x,a3,6x,'*'/ |
---|
40 | &' * geisa geisa *',20x,'spectral interval (cm-1) ', |
---|
41 | &' nu1=',f10.3,3x,'nu2=',f10.3, |
---|
42 | &20x,'* geisa geisa *'/1x,17('*'),98x,17('*')) |
---|
43 | i1=1 |
---|
44 | read (iuni,rec=1) |
---|
45 | &aa1,aa2,anu,n203,nbraie,nbmol,iecr,ifin,ll1,ll2,ll3,ll4 |
---|
46 | if(nu1.gt.aa2.or.nu2.lt.aa1.or.nu1.gt.nu2) go to 200 |
---|
47 | v1=amax1(nu1,aa1) |
---|
48 | v2=amin1(nu2,aa2) |
---|
49 | iadr=int(v1/anu) + 2 - int(aa1/anu) |
---|
50 | C |
---|
51 | C CALCUL DE INU1= NUMERO DU 1ER BLOC A LIRE ET DE I1=1ERE TRANSITION |
---|
52 | C A LIRE DANS CE BLOC |
---|
53 | C |
---|
54 | 5 continue |
---|
55 | ilec=iadr |
---|
56 | read (iuni,rec=ilec) iadr,jadr,k,a1,a2,a3,(v(j),j=1,k) |
---|
57 | if(v1.gt.a1) go to 5 |
---|
58 | C |
---|
59 | C GEISA90 16 -> 29 |
---|
60 | C |
---|
61 | do 10 j=1,k,29 |
---|
62 | if(v1.le.v(j)) go to 13 |
---|
63 | 10 continue |
---|
64 | inu1=iadr |
---|
65 | go to 15 |
---|
66 | 13 continue |
---|
67 | inu1=ilec |
---|
68 | i1=j |
---|
69 | 15 continue |
---|
70 | bb1=v(i1) |
---|
71 | C |
---|
72 | C CALCUL DE INU2= NUMERO DU DERNIER BLOC A LIRE ET DE I2= DERNIERE |
---|
73 | C TRANSITION A LIRE DANS CE BLOC |
---|
74 | C |
---|
75 | iadr=inu1 |
---|
76 | 20 continue |
---|
77 | ilec=iadr |
---|
78 | read (iuni,rec=ilec) iadr,jadr,k,a1,a2,a3,(v(j),j=1,k) |
---|
79 | if(v2.lt.a1) go to 25 |
---|
80 | go to 20 |
---|
81 | 25 continue |
---|
82 | C |
---|
83 | C GEISA90 16 -> 29 |
---|
84 | C |
---|
85 | do 26 j=1,k,29 |
---|
86 | if(v2.le.v(j)) go to 27 |
---|
87 | 26 continue |
---|
88 | C |
---|
89 | C GEISA90 16 -> 29 |
---|
90 | C |
---|
91 | j=j-29 |
---|
92 | 27 continue |
---|
93 | inu2=ilec |
---|
94 | i2=j |
---|
95 | bb2=v(i2) |
---|
96 | nbr=0 |
---|
97 | iaa=2-int(bb1/anu) |
---|
98 | nbreg=int(bb2/anu) + iaa |
---|
99 | jad=1 |
---|
100 | ireg=2 |
---|
101 | iad=nbreg+1 |
---|
102 | mul=1 |
---|
103 | app=0. |
---|
104 | iadr=inu1 |
---|
105 | 50 continue |
---|
106 | ilec=iadr |
---|
107 | read (iuni,rec=ilec) iadr,jadr,k,a1,a2,a3,(v(j),j=1,k) |
---|
108 | iregp=int(a1/anu)+iaa |
---|
109 | if(ilec.eq.inu2) go to 70 |
---|
110 | if(ireg.ne.iregp) go to 60 |
---|
111 | if(ilec.ne.inu1) go to 56 |
---|
112 | C |
---|
113 | C ECRITURE DU BLOC 2 |
---|
114 | C |
---|
115 | do 55 j=i1,k |
---|
116 | 55 v(j-i1+1)=v(j) |
---|
117 | k=k-i1+1 |
---|
118 | 56 continue |
---|
119 | C |
---|
120 | C ZONE D'ECRITURE DES TRANSITIONS AYANT LE MEME |
---|
121 | C IREG=INT(NU/ANU) + 2 - INT(BB1/ANU) |
---|
122 | C |
---|
123 | C SI MUL=1 ECRITURE DU PREMIER BLOC A L'ADRESSE IREG |
---|
124 | C SI MUL=2 ECRITURE DES BLOCS SUIVANTS A L'ADRESSE IECR |
---|
125 | C |
---|
126 | iiii=iecr |
---|
127 | if(mul.eq.1) iiii=ireg |
---|
128 | C |
---|
129 | C ECRITURE DU BLOC ET MISE A JOUR DES PARAMETRES IAD,JAD,APP,IECR |
---|
130 | C |
---|
131 | write(kuni,rec=iiii) iad,jad,k,a1,app,v(k-15),(v(j),j=1,k) |
---|
132 | nbr=nbr+k |
---|
133 | C |
---|
134 | C GEISA90: 15 -> 28 |
---|
135 | C |
---|
136 | app=v(k-28) |
---|
137 | iecr=iad |
---|
138 | jad=iiii |
---|
139 | iad=iad+1 |
---|
140 | mul=2 |
---|
141 | go to 50 |
---|
142 | 60 continue |
---|
143 | C |
---|
144 | C ZONE DE FIN D'ECRITURE DES TRANSITIONS AYANT LE MEME IREG |
---|
145 | C |
---|
146 | C |
---|
147 | C SI MUL=1 ECRITURE DU DERNIER BLOC IREG (C'EST AUSSI LE PREMIER) |
---|
148 | C A L'ADRESSE IREG |
---|
149 | C SI MUL=2 ECRITURE DU DERNIER BLOC A L'ADRESSE IECR |
---|
150 | C |
---|
151 | iiii=iecr |
---|
152 | if(mul.eq.1) iiii=ireg |
---|
153 | C |
---|
154 | C ECRITURE DU BLOC ET MISE A JOUR DES PARAMETRES JAD,IECR,IREG,APP |
---|
155 | C |
---|
156 | write(kuni,rec=iiii) iregp,jad,k,a1,app,v(k-15),(v(j),j=1,k) |
---|
157 | nbr=nbr+k |
---|
158 | C |
---|
159 | C GEISA90: 15 -> 28 |
---|
160 | C |
---|
161 | app=v(k-28) |
---|
162 | iecr=iregp |
---|
163 | jad=iiii |
---|
164 | ireg=iregp |
---|
165 | mul=1 |
---|
166 | go to 50 |
---|
167 | 70 continue |
---|
168 | a1=99999.9 |
---|
169 | C |
---|
170 | C GEISA90: 15 -> 28 |
---|
171 | C |
---|
172 | k=i2+28 |
---|
173 | if(mul.eq.2) ireg=iecr |
---|
174 | C |
---|
175 | C ECRITURE DU DERNIER RECORD DU FICHIER ( NUMERO IECR OU IREG) |
---|
176 | C |
---|
177 | write(kuni,rec=ireg) iad,jad,k,a1,app,v(k-15),(v(j),j=1,k) |
---|
178 | C |
---|
179 | C ECRITURE DU DERNIER RECORD PHYSIQUE CONTENANT DES ZEROS |
---|
180 | C |
---|
181 | write(kuni,rec=iad) izero,izero,izero,zero |
---|
182 | C |
---|
183 | C GEISA90: 16 -> 29 |
---|
184 | C |
---|
185 | nbr=(nbr+k)/29 |
---|
186 | ifin=iad |
---|
187 | C |
---|
188 | C ECRITURE DU PREMIER RECORD CONTENANT LES PARAMETRES |
---|
189 | C |
---|
190 | ll1=0 |
---|
191 | ll2=0 |
---|
192 | ll4=0 |
---|
193 | write(kuni,rec=1) |
---|
194 | &bb1,bb2,anu,n203,nbr,nbmol,iecr,ifin,ll1,ll2,ll3,ll4 |
---|
195 | write(isor,4000) |
---|
196 | 4000 format(///1x,'copy ended successfuly',//) |
---|
197 | write(isor,5000) nbr,bb1,bb2 |
---|
198 | 5000 format(///' total number of transitions : ',i7// |
---|
199 | &' first transition : ',f12.6/ |
---|
200 | &' last transition : ',f12.6/) |
---|
201 | return |
---|
202 | 200 continue |
---|
203 | write(isor,2000) nu1,nu2,nbraie,aa1,aa2 |
---|
204 | 2000 format(/// ' *cop* verify the value of nu1=',f12.6,' and of nu2= |
---|
205 | &',f12.6/09x,'the',i8,' transitions of the spectroscopic data ', |
---|
206 | &' bank are in spectral range '/09x,'v1=',f12.6,' et v2=', |
---|
207 | &f12.6///) |
---|
208 | 130 continue |
---|
209 | return 1 |
---|
210 | end |
---|