source: ether_geisa/trunk/pgm03/copie.f @ 848

C     CE PROGRAMME CREE UN SOUS-FICHIER DE LA BANQUE DANS LA MEME
C     STRUCTURE,C'EST-A-DIRE EXPLOITABLE PAR LE PROGRAMME *** GEISA ***
C       
C     LA COPIE SE FAIT SUR L'UNITE LOGIQUE   2
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
C       
C       MODIF : 06.05.1991 PASSAGE DE 40 A 75 MOLECULES DANS LES COMMON
C       
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
      subroutine copie(v,*)
C       
      character*4 blanc
      character*3 pgm,ianl,iext,itrs,ilst,icop,info,icre,mpgx,
     &            liste,oui
      integer vers
      logical*1 qqq
      real nu1,nu2
      real v(1)
C       
      common/p1/ nu1,nu2,dnu,nbclas,khist,kanal,vers,mode,liste
      common/p3/ imole,iran,ival,pgm,ianl,iext,itrs,ilst,icop,info,icre
      common/p8/ npgx,nfff,mpgx,qqq(75)
      common/entsor/iuni,juni,kuni,ient,isor,iper,nresv,maxx,blanc,oui
C       
      data izero,zero/0,0./
      include 'geisafile.h'
C     INITIALISATION DE L'UNITE LOGIQUE DE LECTURE DE LA BANQUE
      call pgeisa(0.,99999.,*130)
c
C OUVERTURE DU FICHIER KUNI
      len=ltrim(filename_bin)
      open(unit=kuni,status='new',access='direct',recl=11276
     & ,file=filename_bin(1:len))
C       
C     IMPRESSION DU TITRE
C       
C    &'* GEISA   GEISA *'/' *     GEISA     *',98X,'*     GEISA     *'/
C     WRITE(ISOR,900 ) VERS,NU1,NU2
      write(isor,900 ) vers,pgm,pgm,nu1,nu2
900   format(1x,17('*'),98x,17('*')/1x,'* geisa   geisa *',
     &30x,'creation d''un sous-fichier de GEISA',i2.2,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('*'))
      i1=1
      read (iuni,rec=1)
     &aa1,aa2,anu,n203,nbraie,nbmol,iecr,ifin,ll1,ll2,ll3,ll4
      if(nu1.gt.aa2.or.nu2.lt.aa1.or.nu1.gt.nu2) go to 200
      v1=amax1(nu1,aa1)
      v2=amin1(nu2,aa2)
      iadr=int(v1/anu) + 2 - int(aa1/anu)
C       
C     CALCUL DE INU1= NUMERO DU 1ER BLOC A LIRE ET DE I1=1ERE TRANSITION
C     A LIRE DANS CE BLOC
C       
5     continue
      ilec=iadr
      read (iuni,rec=ilec) iadr,jadr,k,a1,a2,a3,(v(j),j=1,k)
      if(v1.gt.a1) go to 5
C       
C GEISA90 16 -> 29
C       
      do 10 j=1,k,29
      if(v1.le.v(j)) go to 13
10    continue
      inu1=iadr
      go to 15
13    continue
      inu1=ilec
      i1=j
15    continue
      bb1=v(i1)
C       
C     CALCUL DE INU2= NUMERO DU DERNIER BLOC A LIRE ET DE I2= DERNIERE
C     TRANSITION A LIRE DANS CE BLOC
C       
      iadr=inu1
20    continue
      ilec=iadr
      read (iuni,rec=ilec) iadr,jadr,k,a1,a2,a3,(v(j),j=1,k)
      if(v2.lt.a1) go to 25
      go to 20
25    continue
C       
C GEISA90 16 -> 29
C       
      do 26 j=1,k,29
      if(v2.le.v(j)) go to 27
26    continue
C       
C GEISA90 16 -> 29
C       
      j=j-29
27    continue
      inu2=ilec
      i2=j
      bb2=v(i2)
      nbr=0
      iaa=2-int(bb1/anu)
      nbreg=int(bb2/anu) + iaa
      jad=1
      ireg=2
      iad=nbreg+1
      mul=1
      app=0.
      iadr=inu1
50    continue
      ilec=iadr
      read (iuni,rec=ilec) iadr,jadr,k,a1,a2,a3,(v(j),j=1,k)
      iregp=int(a1/anu)+iaa
      if(ilec.eq.inu2) go to 70
      if(ireg.ne.iregp) go to 60
      if(ilec.ne.inu1) go to 56
C       
C     ECRITURE DU BLOC 2
C       
      do 55 j=i1,k
55    v(j-i1+1)=v(j)
      k=k-i1+1
56    continue
C       
C     ZONE D'ECRITURE DES TRANSITIONS AYANT LE MEME
C     IREG=INT(NU/ANU) + 2 - INT(BB1/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       
      iiii=iecr
      if(mul.eq.1) iiii=ireg
C       
C     ECRITURE DU BLOC ET MISE A JOUR DES PARAMETRES IAD,JAD,APP,IECR
C       
      write(kuni,rec=iiii) iad,jad,k,a1,app,v(k-15),(v(j),j=1,k)
      nbr=nbr+k
C       
C GEISA90:  15 -> 28
C       
      app=v(k-28)
      iecr=iad
      jad=iiii
      iad=iad+1
      mul=2
      go to 50
60    continue
C       
C     ZONE DE FIN D'ECRITURE DES TRANSITIONS AYANT LE MEME IREG
C       
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       
      iiii=iecr
      if(mul.eq.1) iiii=ireg
C       
C     ECRITURE DU BLOC ET MISE A JOUR DES PARAMETRES JAD,IECR,IREG,APP
C       
      write(kuni,rec=iiii) iregp,jad,k,a1,app,v(k-15),(v(j),j=1,k)
      nbr=nbr+k
C       
C GEISA90:  15 -> 28
C       
      app=v(k-28)
      iecr=iregp
      jad=iiii
      ireg=iregp
      mul=1
      go to 50
70    continue
      a1=99999.9
C       
C GEISA90:  15 -> 28
C       
      k=i2+28
      if(mul.eq.2) ireg=iecr
C       
C     ECRITURE DU DERNIER RECORD DU FICHIER ( NUMERO IECR OU IREG)
C       
      write(kuni,rec=ireg) iad,jad,k,a1,app,v(k-15),(v(j),j=1,k)
C       
C     ECRITURE DU DERNIER RECORD PHYSIQUE CONTENANT DES ZEROS
C       
      write(kuni,rec=iad) izero,izero,izero,zero
C       
C GEISA90:  16 -> 29
C       
      nbr=(nbr+k)/29
      ifin=iad
C       
C     ECRITURE DU PREMIER RECORD CONTENANT LES PARAMETRES
C       
      ll1=0
      ll2=0
      ll3=-100
      ll4=0
      write(kuni,rec=1)
     &bb1,bb2,anu,n203,nbr,nbmol,iecr,ifin,ll1,ll2,ll3,ll4
      write(isor,4000) 
4000  format(///1x,'copy ended successfuly',//)
      write(isor,5000) nbr,bb1,bb2
5000  format(///' total number of transitions : ',i7//
     &'  first   transition : ',f12.6/
     &'  last    transition : ',f12.6/)
      return
200   continue
      write(isor,2000) nu1,nu2,nbraie,aa1,aa2
2000  format(/// ' *cop*   verify the value of nu1=',f12.6,' and of nu2= 
     &',f12.6/09x,'the',i8,' transitions of the spectroscopic data ',
     &' bank are in spectral range '/09x,'v1=',f12.6,' et v2=',
     &f12.6///)
130   continue
      return 1
      end