Télécharger la plaquette Cast3M


fr en

Télécharger ecdifr.eso

Retour à la liste

Numérotation des lignes : 

ecdifr

  1. C ECDIFR    SOURCE    FANDEUR   22/03/10    21:15:03     11313          
  2.       SUBROUTINE ECDIFR(NBAND,LMAX,R,IFORM)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5.  
  6. -INC PPARAM
  7. -INC CCOPTIO
  8. -INC CCFXDR
  9.       EXTERNAL LONG
  10.       DIMENSION R(*)
  11.       dimension rc(lmax+1)
  12.       logical compr
  13.  
  14.       IF (LMAX.EQ.0) RETURN
  15.  
  16.       DIMATT=DIMATT+LMAX*2
  17.       dimato= dimatt
  18.       IF( DIMATT.GT.DIMFIC) THEN
  19.         DIMATT=LMAX*2 +1
  20.         ll = long(NOMSAU)
  21.         iprefi=iprefi+1
  22.         if(iprefi.eq.1) THEN
  23.           NOMSAU(ll+1:ll+2)='_1'
  24.           ll=ll+2
  25.         elseif(iprefi.lt.10) then
  26.           write(NOMSAU(ll:ll),fmt='(I1)')iprefi
  27.         elseif(iprefi.lt.100) then
  28.           if(iprefi.eq.10)ll = ll + 1
  29.           write(NOMSAU(ll-1:ll),fmt='(I2)')iprefi
  30.         elseif(iprefi.lt.1000) then
  31.           if(iprefi.eq.100) ll = ll + 1
  32.           write(NOMSAU(ll-2:ll),fmt='(I3)')iprefi
  33.         elseif(iprefi.lt.10000) then
  34.           if(iprefi.eq.1000) ll = ll + 1
  35.           write(NOMSAU(ll-3:ll),fmt='(I4)')iprefi
  36.         else
  37.           call erreur (945)
  38.           return
  39. *          call erreur (1003)
  40.         endif
  41.         if (iform.ne.2) close (unit=nband)
  42.         if (iform.eq.2) ios=IXDRCLOSE( ixdrw,.TRUE. )
  43.  
  44.         if(iform.eq.1) then
  45.           OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMSAU(1:ll),
  46.      #    IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  47.         elseif (iform.eq.0) then
  48.           OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMSAU(1:ll),
  49.      #    IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
  50.         elseif (iform.eq.2) then
  51.           ios= initxdr(NOMSAU(1:ll),'w',.TRUE.)
  52.         endif
  53.        write(ioimp,*) 'ecdifr : Ouverture du fichier : ',NOMSAU(1:ll)
  54. *      write(ioimp,*) 'dimfic , dimatold , dimatt ',dimfic,dimato,dimatt
  55.       endif
  56. * compression des donnees
  57.       if (lmax.eq.0) goto 10
  58.  
  59.       i=1
  60.       icp=1
  61.       ic=2
  62.       compr=.false.
  63.       rc(1)=-1.002017000000000000
  64.       rc(2)=r(1)
  65.  
  66. 1954  continue
  67.       i=i+1
  68.       if (i.gt.lmax) goto 1955
  69.  
  70.        if (r(i).eq.rc(ic)) then
  71. *  on stocke le nb de terme identique suivi de la valeur
  72.         if (compr) then
  73.          rc(ic-1)=rc(ic-1)+1
  74.         else
  75.          if (i.lt.lmax.and.r(i+1).eq.r(i)) then
  76.           compr=.true.
  77.           rc(icp)=rc(icp)+1
  78.           rc(ic+1)=rc(ic)
  79.           if (rc(icp).gt.-0.5) then
  80. *  0 valeurs differentes avant. On efface le marqueur
  81.            ic=ic-1
  82.           endif
  83.           rc(ic)=2.0020170000000
  84.           ic=ic+1
  85.          else
  86. * au moins 3 valeurs identiques pour comprimer
  87.           rc(icp)=rc(icp)-1
  88.           ic=ic+1
  89.           rc(ic)=r(i)
  90.          endif
  91.         endif
  92.        else
  93. *  on stocke le nb de terme different suivi des valeurs
  94.         if (compr) then
  95.           compr=.false.
  96.           icp=ic+1
  97.           rc(icp)=-1.1
  98.           ic=icp+1
  99.           rc(ic)=r(i)
  100.          else
  101.           rc(icp)=rc(icp)-1
  102.           ic=ic+1
  103.           rc(ic)=r(i)
  104.          endif
  105.        endif
  106.       goto 1954
  107. 1955  continue
  108. 1956  continue
  109. **      write (6,*) 'ecdifr avant ',lmax
  110. **      write (6,*) (r(i),i=1,min(lmax,255))
  111. **      write (6,*) 'ecdifr apres ',ic
  112. **      write (6,*) (rc(i),i=1,min(ic,255))
  113.  
  114.       IF(IONIVE.GT.19) THEN
  115.         DIMATT = DIMATT - LMAX*2+IC*2
  116.         IF(IFORM.EQ.1) then
  117.          WRITE(NBAND,8004) ic
  118.          WRITE(NBAND,8003) (Rc(I),I=1,ic)
  119.         endif
  120.         IF(IFORM.EQ.0) then
  121.          WRITE(NBAND) ic
  122.          WRITE(NBAND) (Rc(I),I=1,ic)
  123.         endif
  124.         if (iform.eq.2) then
  125. * segmentation au dela de 500000000 de termes pour eviter une ecriture de plus de 2**32 octets
  126.        if (ic.lt.500000000) then
  127.          ios=IXDRint( ixdrw, ic)
  128.          ios=IXDRDMAT( ixdrw, ic,rc(1))
  129.        else
  130.         nc=(ic-1)/500000000+1
  131.         ios=IXDRINT ( ixdrw, -nc)
  132.         do is=0,nc-1
  133.          lc=min(500000000,ic-is*500000000)
  134. **      write(6,*) ' ecriture n ',is,'nb termes ',lc,' nbtot ',ic
  135.          ios=IXDRINT ( ixdrw, lc)
  136.          ios=IXDRDMAT( ixdrw, lc,rc(1))
  137.         enddo
  138.        endif
  139.  
  140.       endif
  141.  
  142.  8004   FORMAT(i15)
  143.  8003   FORMAT(1P,3E22.14)
  144.       ELSE
  145.         lmaxl=lmax
  146.         IF(IFORM.EQ.1) WRITE(NBAND,8003) (R(I),I=1,lmaxl)
  147.         IF(IFORM.EQ.0)WRITE(NBAND) (R(I),I=1,lmaxl)
  148.         if (iform.eq.2) ios=IXDRDMAT( ixdrw, lmaxl,r(1))
  149.       ENDIF
  150.   10  continue
  151.       RETURN
  152.  
  153.  2000 continue
  154.       MOTERR=NOMSAU(1:ll)
  155.       INTERR(1)=IOS
  156.       CALL ERREUR(424)
  157.       RETURN
  158.  
  159.       END
  160.  
  161.  
  162.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales