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

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