Télécharger ecdifr.eso

Retour à la liste

Numérotation des lignes :

  1. C ECDIFR SOURCE PV 17/11/09 21:15:03 9602
  2. SUBROUTINE ECDIFR(NBAND,LMAX,R,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 R(*)
  9. dimension rc(lmax+1)
  10. logical compr
  11. IF (LMAX.EQ.0) GO TO 1
  12. DIMATT=DIMATT+LMAX*2
  13. dimato= dimatt
  14. IF( DIMATT.GT.DIMFIC) THEN
  15. DIMATT=LMAX*2 +1
  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,.TRUE. )
  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,*) 'ecdifr : Ouverture du fichier : ',nomfic(1:ll)
  52. ** write(6,*) ' dimfic , dimatold , dimatt ',dimfic,dimato, dimatt
  53. endif
  54. * compression des donnees
  55. if (lmax.eq.0) goto 10
  56.  
  57. i=1
  58. icp=1
  59. ic=2
  60. compr=.false.
  61. rc(1)=-1.002017000000000000
  62. rc(2)=r(1)
  63.  
  64. 1954 continue
  65. i=i+1
  66. if (i.gt.lmax) goto 1955
  67.  
  68. if (r(i).eq.rc(ic)) then
  69. * on stocke le nb de terme identique suivi de la valeur
  70. if (compr) then
  71. rc(ic-1)=rc(ic-1)+1
  72. else
  73. if (i.lt.lmax.and.r(i+1).eq.r(i)) then
  74. compr=.true.
  75. rc(icp)=rc(icp)+1
  76. rc(ic+1)=rc(ic)
  77. if (rc(icp).gt.-0.5) then
  78. * 0 valeurs differentes avant. On efface le marqueur
  79. ic=ic-1
  80. endif
  81. rc(ic)=2.0020170000000
  82. ic=ic+1
  83. else
  84. * au moins 3 valeurs identiques pour comprimer
  85. rc(icp)=rc(icp)-1
  86. ic=ic+1
  87. rc(ic)=r(i)
  88. endif
  89. endif
  90. else
  91. * on stocke le nb de terme different suivi des valeurs
  92. if (compr) then
  93. compr=.false.
  94. icp=ic+1
  95. rc(icp)=-1.1
  96. ic=icp+1
  97. rc(ic)=r(i)
  98. else
  99. rc(icp)=rc(icp)-1
  100. ic=ic+1
  101. rc(ic)=r(i)
  102. endif
  103. endif
  104. goto 1954
  105. 1955 continue
  106. 1956 continue
  107. ** write (6,*) 'ecdifr avant ',lmax
  108. ** write (6,*) (r(i),i=1,min(lmax,255))
  109. ** write (6,*) 'ecdifr apres ',ic
  110. ** write (6,*) (rc(i),i=1,min(ic,255))
  111.  
  112.  
  113.  
  114.  
  115.  
  116.  
  117. IF(IONIVE.GT.19) THEN
  118. DIMATT = DIMATT - LMAX*2+IC*2
  119. IF(IFORM.EQ.1) then
  120. WRITE(NBAND,8004) ic
  121. WRITE(NBAND,8003) (Rc(I),I=1,ic)
  122. endif
  123. IF(IFORM.EQ.0) then
  124. WRITE(NBAND) ic
  125. WRITE(NBAND) (Rc(I),I=1,ic)
  126. endif
  127. if (iform.eq.2) then
  128. ios=IXDRint( ixdrw, ic)
  129. ios=IXDRDMAT( ixdrw, ic,rc(1))
  130. endif
  131.  
  132. 8004 FORMAT(i15)
  133. 8003 FORMAT(1P,3E22.14)
  134. ELSE
  135. lmaxl=lmax
  136. IF(IFORM.EQ.1) WRITE(NBAND,8003) (R(I),I=1,lmaxl)
  137. IF(IFORM.EQ.0)WRITE(NBAND) (R(I),I=1,lmaxl)
  138. if (iform.eq.2) ios=IXDRDMAT( ixdrw, lmaxl,r(1))
  139. ENDIF
  140. 10 continue
  141. 1 RETURN
  142. 2000 continue
  143. MOTERR=NOMfic(1:ll)
  144. INTERR(1)=IOS
  145. CALL ERREUR(424)
  146. RETURN
  147. END
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  

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