C ECDIFR SOURCE FANDEUR 22/03/10 21:15:03 11313 SUBROUTINE ECDIFR(NBAND,LMAX,R,IFORM) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCFXDR EXTERNAL LONG DIMENSION R(*) dimension rc(lmax+1) logical compr IF (LMAX.EQ.0) RETURN DIMATT=DIMATT+LMAX*2 dimato= dimatt IF( DIMATT.GT.DIMFIC) THEN DIMATT=LMAX*2 +1 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,*) 'ecdifr : Ouverture du fichier : ',NOMSAU(1:ll) * write(ioimp,*) 'dimfic , dimatold , dimatt ',dimfic,dimato,dimatt endif * compression des donnees if (lmax.eq.0) goto 10 i=1 icp=1 ic=2 compr=.false. rc(1)=-1.002017000000000000 rc(2)=r(1) 1954 continue i=i+1 if (i.gt.lmax) goto 1955 if (r(i).eq.rc(ic)) then * on stocke le nb de terme identique suivi de la valeur if (compr) then rc(ic-1)=rc(ic-1)+1 else if (i.lt.lmax.and.r(i+1).eq.r(i)) then compr=.true. rc(icp)=rc(icp)+1 rc(ic+1)=rc(ic) if (rc(icp).gt.-0.5) then * 0 valeurs differentes avant. On efface le marqueur ic=ic-1 endif rc(ic)=2.0020170000000 ic=ic+1 else * au moins 3 valeurs identiques pour comprimer rc(icp)=rc(icp)-1 ic=ic+1 rc(ic)=r(i) endif endif else * on stocke le nb de terme different suivi des valeurs if (compr) then compr=.false. icp=ic+1 rc(icp)=-1.1 ic=icp+1 rc(ic)=r(i) else rc(icp)=rc(icp)-1 ic=ic+1 rc(ic)=r(i) endif endif goto 1954 1955 continue 1956 continue ** write (6,*) 'ecdifr avant ',lmax ** write (6,*) (r(i),i=1,min(lmax,255)) ** write (6,*) 'ecdifr apres ',ic ** write (6,*) (rc(i),i=1,min(ic,255)) IF(IONIVE.GT.19) THEN DIMATT = DIMATT - LMAX*2+IC*2 IF(IFORM.EQ.1) then WRITE(NBAND,8004) ic WRITE(NBAND,8003) (Rc(I),I=1,ic) endif IF(IFORM.EQ.0) then WRITE(NBAND) ic WRITE(NBAND) (Rc(I),I=1,ic) endif if (iform.eq.2) then * segmentation au dela de 500000000 de termes pour eviter une ecriture de plus de 2**32 octets if (ic.lt.500000000) then ios=IXDRint( ixdrw, ic) ios=IXDRDMAT( ixdrw, ic,rc(1)) else nc=(ic-1)/500000000+1 ios=IXDRINT ( ixdrw, -nc) do is=0,nc-1 lc=min(500000000,ic-is*500000000) ** write(6,*) ' ecriture n ',is,'nb termes ',lc,' nbtot ',ic ios=IXDRINT ( ixdrw, lc) ios=IXDRDMAT( ixdrw, lc,rc(1)) enddo endif endif 8004 FORMAT(i15) 8003 FORMAT(1P,3E22.14) ELSE lmaxl=lmax IF(IFORM.EQ.1) WRITE(NBAND,8003) (R(I),I=1,lmaxl) IF(IFORM.EQ.0)WRITE(NBAND) (R(I),I=1,lmaxl) if (iform.eq.2) ios=IXDRDMAT( ixdrw, lmaxl,r(1)) ENDIF 10 continue RETURN 2000 continue MOTERR=NOMSAU(1:ll) INTERR(1)=IOS CALL ERREUR(424) RETURN END