1 | C PROGRAMME DE CREATION D'UN FICHIER EN ACCES DIRECT DE TRANSITIONS |
---|
2 | C FICHIER COMPATIBLE AVEC LES PROGRAMMES *** GEISA *** |
---|
3 | C |
---|
4 | C CALL GEISAD(V,V,JUNI,KUNI,PGM,ISOR,FF,*ETIQ) |
---|
5 | C NU2=VALEUR DE LA DERNIERE RAIE A INITIALISER AVANT L'APPEL |
---|
6 | C V=VECTEUR DE TRAVAIL V(2813) |
---|
7 | C JUNI=UNITE LOGIQUE DU FICHIER BINAIRE DES TRANSITIONS |
---|
8 | C KUNI=UNITE LOGIQUE D'ECRITURE DU FICHIER DES TRANSITIONS |
---|
9 | C EN ACCES DIRECT |
---|
10 | C PGM='ASR' APPEL PROVENANT DU PROGRAMME DE MISE A JOUR ASR |
---|
11 | C PGM#'ASR' CREATION D'UN FICHIER DE TRANSITIONS EN ACCES DIRECT |
---|
12 | C |
---|
13 | C L'ENSEMBLE DES TRANSITIONS EST DIVISE EN GROUPES,CHAQUE GROUPE |
---|
14 | C AYANT UNE LONGUEUR DE 100 CM-1. |
---|
15 | C EXEMPLE (0.-99.99) ; (100.-199.99) ... |
---|
16 | C |
---|
17 | C LE RECORD 1 CONTIENT LES PARAMETRES : |
---|
18 | C AA1,AA2,ANU,N203,NBRAIE,IECR,IFIN |
---|
19 | C AA1=PREMIERE TRANSITION |
---|
20 | C AA2=DERNIERE TRANSITION |
---|
21 | C |
---|
22 | C ANU=PAS DU BLOCAGE DES TRANSITIONS (PAR GROUPE DE 100 CM-1) |
---|
23 | C AU MAXIMUM N203=203 ENREGISTREMENTS PAR PISTE |
---|
24 | C NBRAIE=NOMBRE TOTAL DE TRANSITIONS DANS LE FICHIER |
---|
25 | C IECR=NUMERO DERNIER BLOC ECRIT |
---|
26 | C IFIN=NUMERO BLOC A ECRIRE (EN CONTINUATION) A PREVOIR PHYSIQUEMENT |
---|
27 | C |
---|
28 | C NBREG=INT(AA2/ANU) + 2 - INT(AA1/ANU) |
---|
29 | C LES RECORDS DE 2 A NBREG CONTIENNENT LES TRANSITIONS DE DEBUT |
---|
30 | C DES GROUPES |
---|
31 | C IADR=NBREG+1 EST L'ADRESSE DE DEBUT DES BLOCS CHAINES LORSQUE |
---|
32 | C LE NOMBRE DES TRANSITIONS D'UN GROUPE DEPASSE N203 |
---|
33 | C |
---|
34 | C IADR,JADR,K,A1,A2,A3,(VECT(J),J=1,K) |
---|
35 | C IADR=ADRESSE DU BLOC SUIVANT A LIRE |
---|
36 | C JADR=ADRESSE DU BLOC PRECEDENT QUI A ETE LU |
---|
37 | C A1=PREMIERE VALEUR DE NU DANS LE BLOC SUIVANT |
---|
38 | C A2=DERNIERE VALEUR DE NU DANS LE BLOC PRECEDENT |
---|
39 | C A3=DERNIERE VALEUR DE NU DANS LE BLOC ACTUEL |
---|
40 | C V(1)=PREMIERE VALEUR DE NU DANS LE BLOC ACTUEL |
---|
41 | C |
---|
42 | C LL1=NOMBRE DE PISTES RESERVEES POUR STOCKER RESULTATS *TRS* |
---|
43 | C LL2=NOMBRE DE PISTES RESERVEES POUR STOCKER RESULTATS *ANL* |
---|
44 | C LL3=NUMERO DE VERSION |
---|
45 | C LL4=INCREMENT QUI SERT A CHERCHER LA PISTE SUR LAQUELLE ON ECRIT |
---|
46 | C LES INFORMATIONS UTILISATEURS A CE MOMENT |
---|
47 | C |
---|
48 | C-------------------------------------------------------------------- |
---|
49 | C M.a.j.: 11.03.1997 passage de v(2) en double precision |
---|
50 | C-------------------------------------------------------------------- |
---|
51 | subroutine geisad( v,iv,juni,kuni,pgm,isor,fb,*) |
---|
52 | C |
---|
53 | logical*1 jasr |
---|
54 | character*90 fb |
---|
55 | character*7 form,bin |
---|
56 | character*3 pgm,liste,modif,iasr,remp,supp,ajou |
---|
57 | integer iv(1),vers |
---|
58 | C |
---|
59 | C GEISA90 : 16 -> 29 |
---|
60 | C |
---|
61 | real nu2,a(29),v(1),b(29) |
---|
62 | CBB 11.03 passage en double precision de v(2) |
---|
63 | real*8 a2,cor,b2 |
---|
64 | CBB fin |
---|
65 | common/p1/ nu1,nu2,dnu,nbclas,khist,kanal,vers,mode,liste |
---|
66 | common/p4/ nmol,knmol,ksot,kksot,ntab,nhist,kp,lre,form,bin,modif |
---|
67 | common/p6/ iasr,remp,supp,ajou,imp8,imp9,in40,in41,in42,in43,n97 |
---|
68 | C |
---|
69 | CBB equivalence (b(2),b2),(b(4),b4),(b(15),izb),(b(16),imb) |
---|
70 | equivalence (b(4),b4),(b(15),izb),(b(16),imb) |
---|
71 | equivalence (n203,n97) |
---|
72 | equivalence (b(1),b1) |
---|
73 | CBB equivalence (a(1),a1),(a(2),a2),(a(4),a4) |
---|
74 | equivalence (a(1),a1),(a(4),a4) |
---|
75 | equivalence (a(15),isot),(a(16),imol) |
---|
76 | C |
---|
77 | data anu,izero,zero/100.,0,0./,cor/1.d50/ |
---|
78 | C |
---|
79 | C INITIALISATION DES PARAMETRES ET DEBUT DU CALCUL |
---|
80 | C |
---|
81 | app=0. |
---|
82 | jasr=.true. |
---|
83 | nbraie=0 |
---|
84 | 5 read (juni,fb,err=4141) a(1),a2,(a(kk),kk=3,24) |
---|
85 | go to 4242 |
---|
86 | 4141 print *,'mauvais record lu(3): ' |
---|
87 | write(*,fb) a(1),a2,(a(kk),kk=3,24) |
---|
88 | 4242 if(a1.eq.999.998779)fb(6:7)=' 5' |
---|
89 | if(a1.eq.9999.48828) fb(6:7)=' 4' |
---|
90 | if(a4.ge.0.) go to 6 |
---|
91 | read (juni,fb,err=4747) b(1),b2,(b(kk),kk=3,24) |
---|
92 | go to 4848 |
---|
93 | 4747 print *,'mauvais record lu(4): ' |
---|
94 | write(*,fb) b(1),b2,(b(kk),kk=3,24) |
---|
95 | 4848 go to 5 |
---|
96 | 6 continue |
---|
97 | if(a2.lt.0.) a2=-a2 |
---|
98 | 7 continue |
---|
99 | write(isor,1000) pgm,pgm,a1,nu2 |
---|
100 | 1000 format(1x,17('*'),98x,17('*')/1x,'* geisa geisa *', |
---|
101 | &30x,'creation d''un fichier type / geisa / ' ,31x, |
---|
102 | &'* geisa geisa *'/' *',6x,a3,6x,'*',98x,'*',6x,a3,6x,'*'/ |
---|
103 | &' * geisa geisa *',20x,'spectral interval (cm-1) ', |
---|
104 | &' nu1=',f10.3,3x,'nu2=',f10.3, |
---|
105 | &20x,'* geisa geisa *'/1x,17('*'),98x,17('*')) |
---|
106 | aa1=a1 |
---|
107 | iaa=2-int(aa1/anu) |
---|
108 | nbreg=int(nu2/anu) + iaa |
---|
109 | iadr=nbreg+1 |
---|
110 | jadr=1 |
---|
111 | ireg=2 |
---|
112 | mul=1 |
---|
113 | k=0 |
---|
114 | C |
---|
115 | C GEISA90: 16 -> 29 |
---|
116 | C |
---|
117 | nk=n203*29 |
---|
118 | 10 continue |
---|
119 | C |
---|
120 | C GEISA90: 16 -> 29 |
---|
121 | C |
---|
122 | v(k+1)=a(1) |
---|
123 | v(k+2)=a2*cor |
---|
124 | do 11 j=3,29 |
---|
125 | v(k+j)=a(j) |
---|
126 | 11 continue |
---|
127 | C |
---|
128 | C GEISA90: 16 -> 29 |
---|
129 | C |
---|
130 | k=k+29 |
---|
131 | 12 read (juni,fb,end=30,err=4545) a(1),a2,(a(kk),kk=3,24) |
---|
132 | if(a1.eq.999.998779)fb(6:7)=' 5' |
---|
133 | if(a1.eq.9999.48828) fb(6:7)=' 4' |
---|
134 | if(jasr) go to 13 |
---|
135 | go to 4546 |
---|
136 | 4545 print *,' record mauvais',a |
---|
137 | 4546 continue |
---|
138 | C SI L'APPEL PROVIENT DU PROGRAMME ASR ELIMINER LES |
---|
139 | C TRANSITIONS TEL QUE A4<0 |
---|
140 | C ET CHANGER LE SIGNE DE A2 SI A2<0 |
---|
141 | C |
---|
142 | if(a4.ge.0.) go to 125 |
---|
143 | if(a4.lt.-99998.) a4=0. |
---|
144 | a4=-a4 |
---|
145 | read (juni,fb) b(1),b2,(b(kk),kk=3,24) |
---|
146 | C |
---|
147 | C GEISA90: 16 -> 29 |
---|
148 | C |
---|
149 | if(a(1).ne.b(1)) go to 122 |
---|
150 | if(a2.ne.b2) go to 122 |
---|
151 | do 121 j=3,29 |
---|
152 | if(a(j).ne.b(j)) go to 122 |
---|
153 | 121 continue |
---|
154 | go to 12 |
---|
155 | 122 continue |
---|
156 | write(imp8,1002)a(1),a2,(a(j),j=3,14),isot,imol |
---|
157 | 1002 format(' *geisad* not deleted line : ',f12.6,d10.3,f5.3,f10.3, |
---|
158 | &8a4,a3,a3,i4,i3) |
---|
159 | C |
---|
160 | C GEISA90: 16 -> 29 |
---|
161 | C |
---|
162 | a(1)=b(1) |
---|
163 | a2=b2 |
---|
164 | do 123 j=3,29 |
---|
165 | 123 a(j)=b(j) |
---|
166 | 125 continue |
---|
167 | if(a2.lt.0.) a2=-a2 |
---|
168 | 13 continue |
---|
169 | iregp=int(a1/anu)+iaa |
---|
170 | if(ireg.ne.iregp) go to 20 |
---|
171 | if(k.ne.nk) go to 10 |
---|
172 | C |
---|
173 | C ZONE D'ECRITURE DES TRANSITIONS AYANT LE MEME |
---|
174 | C IREG=INT(NU/ANU) + 2 - INT(AA1/ANU) |
---|
175 | C |
---|
176 | C SI MUL=1 ECRITURE DU PREMIER BLOC A L'ADRESSE IREG |
---|
177 | C SI MUL=2 ECRITURE DES BLOCS SUIVANTS A L'ADRESSE IECR |
---|
178 | C |
---|
179 | nbraie=nbraie+k |
---|
180 | iiii=iecr |
---|
181 | if(mul.eq.1) iiii=ireg |
---|
182 | C |
---|
183 | C |
---|
184 | C ECRITURE DU BLOC ET MISE A JOUR DES PARAMETRES IADR,JADR,IECR,APP |
---|
185 | C |
---|
186 | C GEISA90: 15 -> 28 |
---|
187 | C |
---|
188 | write(kuni,rec=iiii) iadr,jadr,k,a1,app,v(k-28),(v(j),j=1,k) |
---|
189 | C |
---|
190 | C GEISA90: 15 -> 28 |
---|
191 | C |
---|
192 | app=v(k-28) |
---|
193 | iecr=iadr |
---|
194 | jadr=iiii |
---|
195 | iadr=iadr+1 |
---|
196 | mul=2 |
---|
197 | k=0 |
---|
198 | go to 10 |
---|
199 | 20 continue |
---|
200 | C |
---|
201 | C ZONE DE FIN D'ECRITURE DES TRANSITIONS AYANT LE MEME IREG |
---|
202 | C |
---|
203 | C SI MUL=1 ECRITURE DU DERNIER BLOC IREG (C'EST AUSSI LE PREMIER) |
---|
204 | C A L'ADRESSE IREG |
---|
205 | C SI MUL=2 ECRITURE DU DERNIER BLOC A L'ADRESSE IECR |
---|
206 | C |
---|
207 | nbraie=nbraie+k |
---|
208 | iiii=iecr |
---|
209 | if(mul.eq.1) iiii=ireg |
---|
210 | C |
---|
211 | C ECRITURE DU BLOC ET MISE A JOUR DES PARAMETRES JADR,IECR,IREG,APP |
---|
212 | C |
---|
213 | C GEISA90: 15 -> 28 |
---|
214 | C |
---|
215 | write(kuni,rec=iiii) iregp,jadr,k,a1,app,v(k-28),(v(j),j=1,k) |
---|
216 | C |
---|
217 | C GEISA90: 15 -> 28 |
---|
218 | C |
---|
219 | app=v(k-28) |
---|
220 | iecr=iregp |
---|
221 | jadr=iiii |
---|
222 | ireg=iregp |
---|
223 | mul=1 |
---|
224 | k=0 |
---|
225 | go to 10 |
---|
226 | 30 continue |
---|
227 | a1=99999.9 |
---|
228 | C |
---|
229 | C GEISA90: 15 -> 28 |
---|
230 | C |
---|
231 | aa2=v(k-28) |
---|
232 | C |
---|
233 | C GEISA90: 16 -> 29 |
---|
234 | C |
---|
235 | nbraie=(nbraie+k)/29 |
---|
236 | C |
---|
237 | C ECRITURE DU DERNIER RECORD DU FICHIER ( NUMERO IECR OU IREG) |
---|
238 | C |
---|
239 | if(mul.eq.2) ireg=iecr |
---|
240 | C |
---|
241 | C GEISA90: 15 -> 28 |
---|
242 | C |
---|
243 | write(kuni,rec=ireg) iadr,jadr,k,a1,app,v(k-28),(v(j),j=1,k) |
---|
244 | C |
---|
245 | C ECRITURE DU DERNIER RECORD PHYSIQUE CONTENANT DES ZEROS |
---|
246 | C |
---|
247 | write(kuni,rec=iadr) izero,izero,izero,zero |
---|
248 | C |
---|
249 | C ECRITURE DU PREMIER RECORD CONTENANT LES PARAMETRES |
---|
250 | C |
---|
251 | ifin=iadr |
---|
252 | ll1=0 |
---|
253 | ll2=0 |
---|
254 | ll3=0 |
---|
255 | ll3=-100 |
---|
256 | ll4=0 |
---|
257 | write(kuni,rec=1) |
---|
258 | &aa1,aa2,anu,n203,nbraie,nmol,iecr,ifin,ll1,ll2,ll3,ll4 |
---|
259 | write(isor,2000) |
---|
260 | 2000 format(///1x,'creat ended successfuly'//) |
---|
261 | if(jasr) write(isor,3000) nbraie,aa1,aa2 |
---|
262 | 3000 format(' total number of transitions : ',i7// |
---|
263 | &' premiere transition : ',f12.6/ |
---|
264 | &' derniere transition : ',f12.6/) |
---|
265 | if(jasr) go to 40 |
---|
266 | iecc=int(aa2/anu)+2-int(aa1/anu) |
---|
267 | iecr1=iecc+1 |
---|
268 | write(isor,3001) nbraie,aa1,iecc,aa2,iecr1 |
---|
269 | 3001 format(' total number of transitions : ',i7// |
---|
270 | &' first transition : ',f12.6,6x,'number of catalogued blocks : |
---|
271 | & 2 a ',i4/' last transition : ',f12.6,6x,'number of continu |
---|
272 | &ed blocks : ',i3/) |
---|
273 | iadr=2 |
---|
274 | iecr1=int(aa2/anu) + 2 -int(aa1/anu) |
---|
275 | 35 continue |
---|
276 | ilec=iadr |
---|
277 | read (kuni,rec=ilec) iadr,jadr,k,c1,c2,c3,c4,(v(j),j=1,k) |
---|
278 | C |
---|
279 | C GEISA90: 16 -> 29 |
---|
280 | C |
---|
281 | do 36 i=1,k,29 |
---|
282 | if(v(i+1).lt.0..or.v(i+3).lt.0..or.iv(i+15).lt.0) |
---|
283 | &write(imp8,3003) pgm,(v(i+j-1),j=1,14),iv(i+14),iv(i+15) |
---|
284 | 3003 format(' *',a3,'*/geisad error on the transition : ',f12.6, |
---|
285 | &e10.3,f5.3,f10.3,8a4,a3,a3,i4,i3) |
---|
286 | 36 continue |
---|
287 | if(iadr.ne.ifin) go to 35 |
---|
288 | 40 continue |
---|
289 | return |
---|
290 | 500 continue |
---|
291 | return 1 |
---|
292 | end |
---|
293 | |
---|