Télécharger la plaquette Cast3M


fr en

Télécharger ecdife.eso

Retour à la liste

Numérotation des lignes : 

ecdife

  1. C ECDIFE    SOURCE    OF166741  24/12/18    21:15:03     12091          
  2.  
  3.       SUBROUTINE ECDIFE(NBAND,LMAX,ITAB,IFORM)
  4.  
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8 (A-H,O-Z)
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC CCFXDR
  11.  
  12.       EXTERNAL LONG
  13.  
  14.       DIMENSION ITAB(*)
  15.  
  16.       DIMENSION itabc(lmax+1)
  17.       LOGICAL compr
  18.  
  19.       IF (LMAX.EQ.0) RETURN
  20.  
  21. C-BEBUT- Bloc pouvant faire l'objet d'un sous-programme generique -
  22.       DIMATT=DIMATT+LMAX+1
  23.       IF (DIMATT.GT.DIMFIC) THEN
  24. c-dbg        dimatold = dimatt
  25.         DIMATT=LMAX
  26.         ll = LONG(NOMSAU)
  27.         iprefi = iprefi+1
  28.         if (iprefi.eq.1) then
  29.           NOMSAU(ll+1:ll+2)='_1'
  30.           ll=ll+2
  31.         else if (iprefi.lt.10) then
  32.           write(NOMSAU(ll:ll),fmt='(I1)') iprefi
  33.         else if (iprefi.lt.100) then
  34.           if (iprefi.eq.10) ll = ll + 1
  35.           write(NOMSAU(ll-1:ll),fmt='(I2)') iprefi
  36.         else if (iprefi.lt.1000) then
  37.           if (iprefi.eq.100) ll = ll + 1
  38.           write(NOMSAU(ll-2:ll),fmt='(I3)') iprefi
  39.         else if (iprefi.lt.10000) then
  40.           if (iprefi.eq.1000) ll = ll + 1
  41.           write(NOMSAU(ll-3:ll),fmt='(I4)') iprefi
  42.         else
  43.           call erreur (945)
  44. *          call erreur (1003)
  45.           return
  46.         endif
  47.  
  48.         if (iform.ne.2) close (unit=nband)
  49.         if (iform.eq.2) ios=IXDRCLOSE( ixdrw,.true.)
  50.  
  51.         if(iform.eq.1) then
  52.           OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMSAU(1:ll),
  53.      #    IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  54.         elseif (iform.eq.0) then
  55.           OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMSAU(1:ll),
  56.      #    IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
  57.         elseif (iform.eq.2) then
  58.           ios= initxdr(NOMSAU(1:ll),'w',.TRUE.)
  59.         endif
  60.         write(ioimp,*) 'ecdife : Ouverture du fichier : ',NOMSAU(1:ll)
  61. c-dbg        write(ioimp,*) ' dimfic , dimatold , dimatt ',dimfic,dimatold,dimatt
  62.       ENDIF
  63.  
  64. * Compression des donnees (depuis le niveau 20)
  65.       IF (ionive.GE.20) THEN
  66.       i   = 1
  67.       icp = 1
  68.       ic  = 2
  69.       compr = .false.
  70.       itabc(1) = -1
  71.       itabc(2) = itab(1)
  72.  
  73. 1954  continue
  74.         i=i+1
  75.         if (i.gt.lmax) goto 1955
  76.  
  77.         if (itab(i).eq.itabc(ic)) then
  78. *  on stocke le nb de termes identiques suivi de la valeur
  79.           if (compr) then
  80.             itabc(ic-1)=itabc(ic-1)+1
  81.           else
  82.             if (i.lt.lmax .and. itab(i+1).eq.itab(i)) then
  83.               compr=.true.
  84.               itabc(icp)=itabc(icp)+1
  85.               itabc(ic+1)=itabc(ic)
  86.               if (itabc(icp).ge.0) then
  87. *  0 valeur differente avant. On efface le marqueur
  88.                 ic=ic-1
  89.               endif
  90.               itabc(ic)=2
  91.               ic=ic+1
  92.             else
  93. * au moins 3 valeurs identiques pour comprimer
  94.               itabc(icp)=itabc(icp)-1
  95.               ic=ic+1
  96.               itabc(ic)=itab(i)
  97.             endif
  98.           endif
  99.         else
  100. *  on stocke le nb de termes differents suivi des valeurs
  101.           if (compr) then
  102.             compr=.false.
  103.             icp=ic+1
  104.             itabc(icp)=-1
  105.             ic=icp+1
  106.             itabc(ic)=itab(i)
  107.           else
  108.             itabc(icp)=itabc(icp)-1
  109.             ic=ic+1
  110.             itabc(ic)=itab(i)
  111.           endif
  112.         endif
  113.       GOTO 1954
  114.  1955 CONTINUE
  115.       DIMATT = DIMATT - LMAX + IC
  116.       IF (IFORM.EQ.1) then
  117.         IF (IONIVE .GE. 26) THEN
  118.           WRITE(NBAND,8010) ic
  119.           WRITE(NBAND,8010) (ITABC(i),i=1,ic)
  120.  8010     FORMAT(10(1X,I12))
  121.         ELSE
  122.           WRITE(NBAND,8000) ic
  123.           WRITE(NBAND,8000) (ITABC(i),i=1,ic)
  124.  8000     FORMAT(10I8)
  125.         ENDIF
  126.       ENDIF
  127.       IF (IFORM.EQ.0) then
  128.         write(nband) ic
  129.         WRITE(NBAND) (ITABC(i),i=1,ic)
  130.       endif
  131.       IF (iform.eq.2) then
  132.         ios=IXDRINT ( ixdrw, ic)
  133.         ios=IXDRIMAT( ixdrw, ic,itabc(1))
  134.       ENDIF
  135.  
  136. * Sortie brute des donnees (avant le niveau 20)
  137.       ELSE
  138.         lmaxl = LMAX
  139.         IF (IFORM.EQ.1)WRITE(NBAND,8001) (ITAB(i),i=1,lmaxl)
  140.  8001   FORMAT(10I8)
  141.         IF (IFORM.EQ.0)WRITE(NBAND) (ITAB(i),i=1,lmaxl)
  142.         IF (iform.eq.2) ios=IXDRIMAT( ixdrw, lmaxl,itab(1))
  143.       ENDIF
  144.  
  145.       RETURN
  146.  
  147.  2000 continue
  148.       MOTERR=NOMSAU(1:ll)
  149.       INTERR(1)=IOS
  150.       CALL ERREUR(424)
  151.       RETURN
  152.  
  153.       END
  154.  
  155.  
  156.  

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