Sources Esope | Cast3M

ecdife
C ECDIFE    SOURCE    PV        22/04/15    13:20:08     11344          
      SUBROUTINE ECDIFE(NBAND,LMAX,ITAB,IFORM)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCFXDR
      external LONG
      DIMENSION ITAB(*)
      dimension itabc(lmax+1)
      logical compr
 
      IF (LMAX.EQ.0) RETURN
      DIMATT=DIMATT+LMAX+1
      dimato=dimatt
      IF( DIMATT.GT.DIMFIC) THEN
        DIMATT=LMAX
        ll = long (NOMSAU)
        iprefi=iprefi+1
        if(iprefi.eq.1) THEN
          NOMSAU(ll+1:ll+2)='_1'
          ll=ll+2
        elseif(iprefi.lt.10) then
          write(NOMSAU(ll:ll),fmt='(I1)')iprefi
        elseif(iprefi.lt.100) then
          if(iprefi.eq.10)ll = ll + 1
          write(NOMSAU(ll-1:ll),fmt='(I2)')iprefi
        elseif(iprefi.lt.1000) then
          if(iprefi.eq.100) ll = ll + 1
          write(NOMSAU(ll-2:ll),fmt='(I3)')iprefi
        elseif(iprefi.lt.10000) then
          if(iprefi.eq.1000) ll = ll + 1
          write(NOMSAU(ll-3:ll),fmt='(I4)')iprefi
        else
          call erreur (945)
          return
*          call erreur (1003)
        endif
        if (iform.ne.2) close (unit=nband)
        if (iform.eq.2) ios=IXDRCLOSE( ixdrw,.true.)
 
        if(iform.eq.1) then
          OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMSAU(1:ll),
     #    IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
        elseif (iform.eq.0) then
          OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMSAU(1:ll),
     #    IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
        elseif (iform.eq.2) then
          ios= initxdr(NOMSAU(1:ll),'w',.TRUE.)
        endif
      write(ioimp,*) 'ecdife : Ouverture du fichier : ',NOMSAU(1:ll)
*     write(ioimp,*) ' dimfic , dimatold , dimatt ',dimfic,dimato,dimatt
      endif
      lmaxl=lmax
* compression des donnees
      if (lmax.eq.0) goto 10
 
      i=1
      icp=1
      ic=2
      compr=.false.
      itabc(1)=-1
      itabc(2)=itab(1)
 
1954  continue
      i=i+1
      if (i.gt.lmax) goto 1955
 
       if (itab(i).eq.itabc(ic)) then
*  on stocke le nb de terme identique suivi de la valeur
        if (compr) then
         itabc(ic-1)=itabc(ic-1)+1
        else
         if (i.lt.lmax.and.itab(i+1).eq.itab(i)) then
         compr=.true.
         itabc(icp)=itabc(icp)+1
         itabc(ic+1)=itabc(ic)
          if (itabc(icp).ge.0) then
*  0 valeurs differentes avant. On efface le marqueur
           ic=ic-1
          endif
         itabc(ic)=2
         ic=ic+1
         else
* au moins 3 valeurs identiques pour comprimer
          itabc(icp)=itabc(icp)-1
          ic=ic+1
          itabc(ic)=itab(i)
         endif
        endif
       else
*  on stocke le nb de terme different suivi des valeurs
        if (compr) then
          compr=.false.
          icp=ic+1
          itabc(icp)=-1
          ic=icp+1
          itabc(ic)=itab(i)
         else
          itabc(icp)=itabc(icp)-1
          ic=ic+1
          itabc(ic)=itab(i)
         endif
       endif
      goto 1954
 
1955  continue
      if (ionive.ge.20) then
      DIMATT = DIMATT - LMAX+IC
      IF (IFORM.EQ.1)then
       write (nband,8000) ic
       WRITE(NBAND,8000) (ITABc(I),I=1,ic)
      endif
      IF (IFORM.EQ.0)then
       write (nband) ic
       WRITE(NBAND) (ITABC(I),I=1,ic)
      endif
      IF (iform.eq.2) then
       ios=IXDRINT ( ixdrw, ic)
       ios=IXDRIMAT( ixdrw, ic,itabc(1))
      endif
      else
      lmaxl=lmax
      IF (IFORM.EQ.1)WRITE(NBAND,8000) (ITAB(I),I=1,lmaxl)
      IF (IFORM.EQ.0)WRITE(NBAND) (ITAB(I),I=1,lmaxl)
      IF (iform.eq.2) ios=IXDRIMAT( ixdrw, lmaxl,itab(1))
      endif
  10  continue
 8000 FORMAT(10I8)
 8001 FORMAT(16I5)
      RETURN
 2000 continue
      MOTERR=NOMSAU(1:ll)
      INTERR(1)=IOS
      CALL ERREUR(424)
      RETURN
      END