Télécharger lfcdie.eso

Retour à la liste

Numérotation des lignes :

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

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