Télécharger lfcdi2.eso

Retour à la liste

Numérotation des lignes :

  1. C LFCDI2 SOURCE PV 17/10/05 21:15:01 9584
  2. SUBROUTINE LFCDI2(NBAND,LMAX,R,IRETOU,IFORM)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. -INC CCOPTIO
  6. -INC CCFXDR
  7. DIMENSION R(*)
  8. dimension rc(lmax+1)
  9. external long
  10. ipas=0
  11. 10 IRETOU=0
  12. ios=1
  13. IF (LMAX.EQ.0) return
  14. IF(IONIVE.le.19) THEN
  15. lmaxl=lmax
  16. IF (IFORM.EQ.1) then
  17. if (ionive.gt.2) then
  18. READ(NBAND,8003,END=1001,ERR=1000)(R(I),I=1,LMAX)
  19. else
  20. READ(NBAND,8002,END=1001,ERR=1000)(R(I),I=1,LMAX)
  21. endif
  22. endif
  23. IF (IFORM.EQ.0)READ(NBAND,END=1001,ERR=1000)(R(I),I=1,LMAX)
  24. if (iform.eq.2) then
  25. ios=ixdrdmat(ixdrr,lmaxl,r(1))
  26. if (ios.lt.0) goto 1001
  27. endif
  28. return
  29. Else
  30. ** niveau >= 20
  31. IF(IFORM.EQ.1)then
  32. READ(NBAND,8004,END=1001,ERR=1000)lc
  33. READ(NBAND,8003,END=1001,ERR=1000)(rc(I),I=1,Lc)
  34. endif
  35. IF(IFORM.EQ.0)then
  36. READ(NBAND,END=1001,ERR=1000) lc
  37. READ(NBAND,END=1001,ERR=1000) (rc(I),I=1,Lc)
  38. endif
  39. if(iform.eq.2) then
  40. ios=ixdrint(ixdrr,lc)
  41. if (ios.lt.0) goto 1001
  42. lmaxl=lc
  43. ios=ixdrdmat(ixdrr,lmaxl,rc(1))
  44. if (ios.lt.0) goto 1001
  45. endif
  46. * decompression
  47. i=0
  48. ic=0
  49. icp=0
  50. 1954 continue
  51. if (ic.ge.lc) goto 1955
  52. icp=ic+1
  53. if (rc(icp).gt.0.) then
  54. * comprime
  55. ic=icp+1
  56. do j=1,int(rc(icp))
  57. i=i+1
  58. r(i)=rc(ic)
  59. enddo
  60. ic=icp+1
  61. goto 1954
  62. else
  63. * non comprime
  64. ic=icp
  65. do j=1,int(-rc(icp))
  66. i=i+1
  67. ic=ic+1
  68. r(i)=rc(ic)
  69. enddo
  70. endif
  71. goto 1954
  72. 1955 continue
  73. if (i.ne.lmax) write (6,*) ' pb dans la decompression lfcdi2'
  74. goto 1
  75. endif
  76. 1000 IRETOU=1
  77. write (6,*) ' erreur lfcdi2 '
  78. 1 RETURN
  79. 1001 ll=long (nomres)
  80. ificle=ificle+1
  81. * write(6,*)' ificle ' , ificle
  82. if(ificle.eq.10000)then
  83. call erreur (945)
  84. iretou=1
  85. return
  86. endif
  87. if(ificle.eq.1) then
  88. nomres(ll+1:ll+2)='_1'
  89. ll=ll+2
  90. elseif ( ificle.lt.10) then
  91. write(nomres(ll:ll),fmt='(I1)')ificle
  92. elseif ( ificle.lt.100) then
  93. if(ificle.eq.10)ll = ll + 1
  94. write(nomres(ll-1:ll),fmt='(I2)')ificle
  95. elseif ( ificle.lt.1000) then
  96. if(ificle.eq.100)ll = ll + 1
  97. write(nomres(ll-2:ll),fmt='(I3)')ificle
  98. elseif ( ificle.lt.10000) then
  99. if(ificle.eq.1000)ll = ll + 1
  100. write(nomres(ll-3:ll),fmt='(I4)')ificle
  101. endif
  102. if (iform.ne.2) close (unit=nband)
  103. if (iform.eq.2) ios=IXDRCLOSE( ixdrr )
  104. * write(6,*) ' fermeture et ouverture de ',nomres(1:ll)
  105. if(iform.eq.1) then
  106. OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMRES(1:ll),
  107. # IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  108. ELSEif (iform.eq.0) then
  109. OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMRES(1:ll),
  110. # IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
  111. else
  112. ios=INITXDR( NOMRES(1:ll),'r',.true.)
  113. if (ios.lt.0) goto 2000
  114. ENDIF
  115. write (6,*) 'Ouverture du fichier : ',nomres(1:ll)
  116. go to 10
  117. C --------------------
  118. 8004 FORMAT(i15)
  119. 8002 FORMAT(1P,6E13.6)
  120. 8003 FORMAT(1P,3E22.14)
  121. 2000 MOTERR=NOMRES(1:ll)
  122. INTERR(1)=IOS
  123. CALL ERREUR(424)
  124. RETURN
  125. END
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  
  140.  
  141.  
  142.  
  143.  
  144.  
  145.  
  146.  

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