Télécharger lfcdi2.eso

Retour à la liste

Numérotation des lignes :

  1. C LFCDI2 SOURCE PV 18/10/30 21:15:04 9984
  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. if (lc.gt.0) then
  43. lmaxl=lc
  44. ios=ixdrdmat(ixdrr,lmaxl,rc(1))
  45. ** write (6,*) ' lc ios lmax - 1 ',lc,ios,lmax
  46. if (ios.lt.0) goto 1001
  47. else
  48. nc=-lc
  49. do is=0,nc-1
  50. ios=ixdrint(ixdrr,lc)
  51. ** write (6,*) ' lecture de ',lc,' en ',is*500000000+1
  52. ios=ixdrdmat(ixdrr,lc,rc(is*500000000+1))
  53. if (ios.lt.0) goto 1001
  54. enddo
  55.  
  56. endif
  57. endif
  58. * decompression
  59. i=0
  60. ic=0
  61. icp=0
  62. 1954 continue
  63. if (ic.ge.lc) goto 1955
  64. icp=ic+1
  65. if (rc(icp).gt.0.) then
  66. * comprime
  67. ic=icp+1
  68. do j=1,int(rc(icp))
  69. i=i+1
  70. r(i)=rc(ic)
  71. enddo
  72. ic=icp+1
  73. goto 1954
  74. else
  75. * non comprime
  76. ic=icp
  77. do j=1,int(-rc(icp))
  78. i=i+1
  79. ic=ic+1
  80. r(i)=rc(ic)
  81. enddo
  82. endif
  83. goto 1954
  84. 1955 continue
  85. if (i.ne.lmax) write (6,*) ' pb dans la decompression lfcdi2'
  86. goto 1
  87. endif
  88. 1000 IRETOU=1
  89. write (6,*) ' erreur lfcdi2 '
  90. 1 RETURN
  91. 1001 ll=long (nomres)
  92. ificle=ificle+1
  93. * write(6,*)' ificle ' , ificle
  94. if(ificle.eq.10000)then
  95. call erreur (945)
  96. iretou=1
  97. return
  98. endif
  99. if(ificle.eq.1) then
  100. nomres(ll+1:ll+2)='_1'
  101. ll=ll+2
  102. elseif ( ificle.lt.10) then
  103. write(nomres(ll:ll),fmt='(I1)')ificle
  104. elseif ( ificle.lt.100) then
  105. if(ificle.eq.10)ll = ll + 1
  106. write(nomres(ll-1:ll),fmt='(I2)')ificle
  107. elseif ( ificle.lt.1000) then
  108. if(ificle.eq.100)ll = ll + 1
  109. write(nomres(ll-2:ll),fmt='(I3)')ificle
  110. elseif ( ificle.lt.10000) then
  111. if(ificle.eq.1000)ll = ll + 1
  112. write(nomres(ll-3:ll),fmt='(I4)')ificle
  113. endif
  114. if (iform.ne.2) close (unit=nband)
  115. if (iform.eq.2) ios=IXDRCLOSE( ixdrr )
  116. * write(6,*) ' fermeture et ouverture de ',nomres(1:ll)
  117. if(iform.eq.1) then
  118. OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMRES(1:ll),
  119. # IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  120. ELSEif (iform.eq.0) then
  121. OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMRES(1:ll),
  122. # IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
  123. else
  124. ios=INITXDR( NOMRES(1:ll),'r',.true.)
  125. if (ios.lt.0) goto 2000
  126. ENDIF
  127. write (6,*) 'Ouverture du fichier : ',nomres(1:ll)
  128. go to 10
  129. C --------------------
  130. 8004 FORMAT(i15)
  131. 8002 FORMAT(1P,6E13.6)
  132. 8003 FORMAT(1P,3E22.14)
  133. 2000 MOTERR=NOMRES(1:ll)
  134. INTERR(1)=IOS
  135. CALL ERREUR(424)
  136. RETURN
  137. END
  138.  
  139.  
  140.  
  141.  
  142.  
  143.  
  144.  
  145.  
  146.  
  147.  
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  

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