C PROGRAMME DE CREATION D'UN FICHIER EN ACCES DIRECT DE TRANSITIONS C FICHIER COMPATIBLE AVEC LES PROGRAMMES *** GEISA *** C C CALL GEISAD(V,V,JUNI,KUNI,PGM,ISOR,FF,*ETIQ) C NU2=VALEUR DE LA DERNIERE RAIE A INITIALISER AVANT L'APPEL C V=VECTEUR DE TRAVAIL V(2813) C JUNI=UNITE LOGIQUE DU FICHIER BINAIRE DES TRANSITIONS C KUNI=UNITE LOGIQUE D'ECRITURE DU FICHIER DES TRANSITIONS C EN ACCES DIRECT C PGM='ASR' APPEL PROVENANT DU PROGRAMME DE MISE A JOUR ASR C PGM#'ASR' CREATION D'UN FICHIER DE TRANSITIONS EN ACCES DIRECT C C L'ENSEMBLE DES TRANSITIONS EST DIVISE EN GROUPES,CHAQUE GROUPE C AYANT UNE LONGUEUR DE 100 CM-1. C EXEMPLE (0.-99.99) ; (100.-199.99) ... C C LE RECORD 1 CONTIENT LES PARAMETRES : C AA1,AA2,ANU,N203,NBRAIE,IECR,IFIN C AA1=PREMIERE TRANSITION C AA2=DERNIERE TRANSITION C C ANU=PAS DU BLOCAGE DES TRANSITIONS (PAR GROUPE DE 100 CM-1) C AU MAXIMUM N203=203 ENREGISTREMENTS PAR PISTE C NBRAIE=NOMBRE TOTAL DE TRANSITIONS DANS LE FICHIER C IECR=NUMERO DERNIER BLOC ECRIT C IFIN=NUMERO BLOC A ECRIRE (EN CONTINUATION) A PREVOIR PHYSIQUEMENT C C NBREG=INT(AA2/ANU) + 2 - INT(AA1/ANU) C LES RECORDS DE 2 A NBREG CONTIENNENT LES TRANSITIONS DE DEBUT C DES GROUPES C IADR=NBREG+1 EST L'ADRESSE DE DEBUT DES BLOCS CHAINES LORSQUE C LE NOMBRE DES TRANSITIONS D'UN GROUPE DEPASSE N203 C C IADR,JADR,K,A1,A2,A3,(VECT(J),J=1,K) C IADR=ADRESSE DU BLOC SUIVANT A LIRE C JADR=ADRESSE DU BLOC PRECEDENT QUI A ETE LU C A1=PREMIERE VALEUR DE NU DANS LE BLOC SUIVANT C A2=DERNIERE VALEUR DE NU DANS LE BLOC PRECEDENT C A3=DERNIERE VALEUR DE NU DANS LE BLOC ACTUEL C V(1)=PREMIERE VALEUR DE NU DANS LE BLOC ACTUEL C C LL1=NOMBRE DE PISTES RESERVEES POUR STOCKER RESULTATS *TRS* C LL2=NOMBRE DE PISTES RESERVEES POUR STOCKER RESULTATS *ANL* C LL3=NUMERO DE VERSION C LL4=INCREMENT QUI SERT A CHERCHER LA PISTE SUR LAQUELLE ON ECRIT C LES INFORMATIONS UTILISATEURS A CE MOMENT C C-------------------------------------------------------------------- C M.a.j.: 11.03.1997 passage de v(2) en double precision C-------------------------------------------------------------------- subroutine geisad( v,iv,juni,kuni,pgm,isor,fb,*) C logical*1 jasr character*80 fb character*7 form,bin character*3 pgm,liste,modif,iasr,remp,supp,ajou integer iv(1),vers C C GEISA90 : 16 -> 29 C real nu2,a(29),v(1),b(29) CBB 11.03 passage en double precision de v(2) real*8 a2,cor,b2 CBB fin common/p1/ nu1,nu2,dnu,nbclas,khist,kanal,vers,mode,liste common/p4/ nmol,knmol,ksot,kksot,ntab,nhist,kp,lre,form,bin,modif common/p6/ iasr,remp,supp,ajou,imp8,imp9,in40,in41,in42,in43,n97 C CBB equivalence (b(2),b2),(b(4),b4),(b(15),izb),(b(16),imb) equivalence (b(4),b4),(b(15),izb),(b(16),imb) equivalence (n203,n97) equivalence (b(1),b1) CBB equivalence (a(1),a1),(a(2),a2),(a(4),a4) equivalence (a(1),a1),(a(4),a4) equivalence (a(15),isot),(a(16),imol) C data anu,izero,zero/100.,0,0./,cor/1.d50/ C C INITIALISATION DES PARAMETRES ET DEBUT DU CALCUL C app=0. jasr=.true. nbraie=0 5 read (juni,fb,err=4141) a(1),a2,(a(kk),kk=3,24) go to 4242 4141 print *,'mauvais record lu(3): ' write(*,fb) a(1),a2,(a(kk),kk=3,24) 4242 if(a1.eq.999.998779)fb(6:7)=' 5' if(a1.eq.9999.48828) fb(6:7)=' 4' if(a4.ge.0.) go to 6 read (juni,fb,err=4747) b(1),b2,(b(kk),kk=3,24) go to 4848 4747 print *,'mauvais record lu(4): ' write(*,fb) b(1),b2,(b(kk),kk=3,24) 4848 go to 5 6 continue if(a2.lt.0.) a2=-a2 7 continue write(isor,1000) pgm,pgm,a1,nu2 1000 format(1x,17('*'),98x,17('*')/1x,'* geisa geisa *', &30x,'creation d''un fichier type / geisa / ' ,31x, &'* geisa geisa *'/' *',6x,a3,6x,'*',98x,'*',6x,a3,6x,'*'/ &' * geisa geisa *',20x,'spectral interval (cm-1) ', &' nu1=',f10.3,3x,'nu2=',f10.3, &20x,'* geisa geisa *'/1x,17('*'),98x,17('*')) aa1=a1 iaa=2-int(aa1/anu) nbreg=int(nu2/anu) + iaa iadr=nbreg+1 jadr=1 ireg=2 mul=1 k=0 C C GEISA90: 16 -> 29 C nk=n203*29 10 continue C C GEISA90: 16 -> 29 C v(k+1)=a(1) v(k+2)=a2*cor do 11 j=3,29 v(k+j)=a(j) 11 continue C C GEISA90: 16 -> 29 C k=k+29 12 read (juni,fb,end=30,err=4545) a(1),a2,(a(kk),kk=3,24) if(a1.eq.999.998779)fb(6:7)=' 5' if(a1.eq.9999.48828) fb(6:7)=' 4' if(jasr) go to 13 go to 4546 4545 print *,' record mauvais',a 4546 continue C SI L'APPEL PROVIENT DU PROGRAMME ASR ELIMINER LES C TRANSITIONS TEL QUE A4<0 C ET CHANGER LE SIGNE DE A2 SI A2<0 C if(a4.ge.0.) go to 125 if(a4.lt.-99998.) a4=0. a4=-a4 read (juni,fb) b(1),b2,(b(kk),kk=3,24) C C GEISA90: 16 -> 29 C if(a(1).ne.b(1)) go to 122 if(a2.ne.b2) go to 122 do 121 j=3,29 if(a(j).ne.b(j)) go to 122 121 continue go to 12 122 continue write(imp8,1002)a(1),a2,(a(j),j=3,14),isot,imol 1002 format(' *geisad* not deleted line : ',f12.6,d10.3,f5.3,f10.3, &8a4,a3,a3,i4,i3) C C GEISA90: 16 -> 29 C a(1)=b(1) a2=b2 do 123 j=3,29 123 a(j)=b(j) 125 continue if(a2.lt.0.) a2=-a2 13 continue iregp=int(a1/anu)+iaa if(ireg.ne.iregp) go to 20 if(k.ne.nk) go to 10 C C ZONE D'ECRITURE DES TRANSITIONS AYANT LE MEME C IREG=INT(NU/ANU) + 2 - INT(AA1/ANU) C C SI MUL=1 ECRITURE DU PREMIER BLOC A L'ADRESSE IREG C SI MUL=2 ECRITURE DES BLOCS SUIVANTS A L'ADRESSE IECR C nbraie=nbraie+k iiii=iecr if(mul.eq.1) iiii=ireg C C C ECRITURE DU BLOC ET MISE A JOUR DES PARAMETRES IADR,JADR,IECR,APP C C GEISA90: 15 -> 28 C write(kuni,rec=iiii) iadr,jadr,k,a1,app,v(k-28),(v(j),j=1,k) C C GEISA90: 15 -> 28 C app=v(k-28) iecr=iadr jadr=iiii iadr=iadr+1 mul=2 k=0 go to 10 20 continue C C ZONE DE FIN D'ECRITURE DES TRANSITIONS AYANT LE MEME IREG C C SI MUL=1 ECRITURE DU DERNIER BLOC IREG (C'EST AUSSI LE PREMIER) C A L'ADRESSE IREG C SI MUL=2 ECRITURE DU DERNIER BLOC A L'ADRESSE IECR C nbraie=nbraie+k iiii=iecr if(mul.eq.1) iiii=ireg C C ECRITURE DU BLOC ET MISE A JOUR DES PARAMETRES JADR,IECR,IREG,APP C C GEISA90: 15 -> 28 C write(kuni,rec=iiii) iregp,jadr,k,a1,app,v(k-28),(v(j),j=1,k) C C GEISA90: 15 -> 28 C app=v(k-28) iecr=iregp jadr=iiii ireg=iregp mul=1 k=0 go to 10 30 continue a1=99999.9 C C GEISA90: 15 -> 28 C aa2=v(k-28) C C GEISA90: 16 -> 29 C nbraie=(nbraie+k)/29 C C ECRITURE DU DERNIER RECORD DU FICHIER ( NUMERO IECR OU IREG) C if(mul.eq.2) ireg=iecr C C GEISA90: 15 -> 28 C write(kuni,rec=ireg) iadr,jadr,k,a1,app,v(k-28),(v(j),j=1,k) C C ECRITURE DU DERNIER RECORD PHYSIQUE CONTENANT DES ZEROS C write(kuni,rec=iadr) izero,izero,izero,zero C C ECRITURE DU PREMIER RECORD CONTENANT LES PARAMETRES C ifin=iadr ll1=0 ll2=0 ll4=0 write(kuni,rec=1) &aa1,aa2,anu,n203,nbraie,nmol,iecr,ifin,ll1,ll2,ll3,ll4 write(isor,2000) 2000 format(///1x,'creat ended successfuly'//) if(jasr) write(isor,3000) nbraie,aa1,aa2 3000 format(' total number of transitions : ',i7// &' premiere transition : ',f12.6/ &' derniere transition : ',f12.6/) if(jasr) go to 40 iecc=int(aa2/anu)+2-int(aa1/anu) iecr1=iecc+1 write(isor,3001) nbraie,aa1,iecc,aa2,iecr1 3001 format(' total number of transitions : ',i7// &' first transition : ',f12.6,6x,'number of catalogued blocks : & 2 a ',i4/' last transition : ',f12.6,6x,'number of continu &ed blocks : ',i3/) iadr=2 iecr1=int(aa2/anu) + 2 -int(aa1/anu) 35 continue ilec=iadr read (kuni,rec=ilec) iadr,jadr,k,c1,c2,c3,c4,(v(j),j=1,k) C C GEISA90: 16 -> 29 C do 36 i=1,k,29 if(v(i+1).lt.0..or.v(i+3).lt.0..or.iv(i+15).lt.0) &write(imp8,3003) pgm,(v(i+j-1),j=1,14),iv(i+14),iv(i+15) 3003 format(' *',a3,'*/geisad error on the transition : ',f12.6, &e10.3,f5.3,f10.3,8a4,a3,a3,i4,i3) 36 continue if(iadr.ne.ifin) go to 35 40 continue return 500 continue return 1 end