Télécharger ecdife.eso

Retour à la liste

Numérotation des lignes :

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

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