| 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*80 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 | ll4=0 |
|---|
| 255 | write(kuni,rec=1) |
|---|
| 256 | &aa1,aa2,anu,n203,nbraie,nmol,iecr,ifin,ll1,ll2,ll3,ll4 |
|---|
| 257 | write(isor,2000) |
|---|
| 258 | 2000 format(///1x,'creat ended successfuly'//) |
|---|
| 259 | if(jasr) write(isor,3000) nbraie,aa1,aa2 |
|---|
| 260 | 3000 format(' total number of transitions : ',i7// |
|---|
| 261 | &' premiere transition : ',f12.6/ |
|---|
| 262 | &' derniere transition : ',f12.6/) |
|---|
| 263 | if(jasr) go to 40 |
|---|
| 264 | iecc=int(aa2/anu)+2-int(aa1/anu) |
|---|
| 265 | iecr1=iecc+1 |
|---|
| 266 | write(isor,3001) nbraie,aa1,iecc,aa2,iecr1 |
|---|
| 267 | 3001 format(' total number of transitions : ',i7// |
|---|
| 268 | &' first transition : ',f12.6,6x,'number of catalogued blocks : |
|---|
| 269 | & 2 a ',i4/' last transition : ',f12.6,6x,'number of continu |
|---|
| 270 | &ed blocks : ',i3/) |
|---|
| 271 | iadr=2 |
|---|
| 272 | iecr1=int(aa2/anu) + 2 -int(aa1/anu) |
|---|
| 273 | 35 continue |
|---|
| 274 | ilec=iadr |
|---|
| 275 | read (kuni,rec=ilec) iadr,jadr,k,c1,c2,c3,c4,(v(j),j=1,k) |
|---|
| 276 | C |
|---|
| 277 | C GEISA90: 16 -> 29 |
|---|
| 278 | C |
|---|
| 279 | do 36 i=1,k,29 |
|---|
| 280 | if(v(i+1).lt.0..or.v(i+3).lt.0..or.iv(i+15).lt.0) |
|---|
| 281 | &write(imp8,3003) pgm,(v(i+j-1),j=1,14),iv(i+14),iv(i+15) |
|---|
| 282 | 3003 format(' *',a3,'*/geisad error on the transition : ',f12.6, |
|---|
| 283 | &e10.3,f5.3,f10.3,8a4,a3,a3,i4,i3) |
|---|
| 284 | 36 continue |
|---|
| 285 | if(iadr.ne.ifin) go to 35 |
|---|
| 286 | 40 continue |
|---|
| 287 | return |
|---|
| 288 | 500 continue |
|---|
| 289 | return 1 |
|---|
| 290 | end |
|---|
| 291 | |
|---|
