Télécharger lfcdie.eso

Retour à la liste

Numérotation des lignes :

lfcdie
  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.  
  6. -INC PPARAM
  7. -INC CCOPTIO
  8. -INC CCFXDR
  9. DIMENSION ITAB(1)
  10. dimension itabc(lmax+1)
  11. external LONG
  12. 10 IRETOU=0
  13. ios=1
  14. IF (LMAX.EQ.0) RETURN
  15. if (ionive.le.19) then
  16. lmaxl=lmax
  17. IF (IFORM.EQ.1) then
  18. if (ionive.lt.4) then
  19. READ(NBAND,101,END=1001,ERR=1000)(ITAB(I),I=1,LMAX)
  20. else
  21. READ(NBAND,100,END=1001,ERR=1000)(ITAB(I),I=1,LMAX)
  22. endif
  23. endif
  24. IF (IFORM.EQ.0)READ(NBAND,END=1001,ERR=1000) (ITAB(I),I=1,LMAX)
  25. if(iform.eq.2) ios=IXDRIMAT( ixdrr, lmaxl,itab(1))
  26. if(ios.lt.0) go to 1001
  27. 100 FORMAT(10I8)
  28. 101 FORMAT(16I5)
  29. RETURN
  30. else
  31. IF(IFORM.EQ.1)then
  32. READ(NBAND,100,END=1001,ERR=1000)lc
  33. READ(NBAND,100,END=1001,ERR=1000)(ITABc(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) (ITABc(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=ixdrimat(ixdrr,lmaxl,itabc(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 (itabc(icp).gt.0) then
  54. * comprime
  55. ic=icp+1
  56. do j=1,int(itabc(icp))
  57. i=i+1
  58. itab(i)=itabc(ic)
  59. enddo
  60. ic=icp+1
  61. goto 1954
  62. else
  63. * non comprime
  64. ic=icp
  65. do j=1,int(-itabc(icp))
  66. i=i+1
  67. ic=ic+1
  68. itab(i)=itabc(ic)
  69. enddo
  70. endif
  71. goto 1954
  72. 1955 continue
  73. if (i.ne.lmax) write (6,*) ' pb dans la decompression lfcdie '
  74. return
  75. endif
  76.  
  77.  
  78. 1001 CONTINUE
  79. * on bascule sur le fichier suivant
  80. ll = long (nomres)
  81. ificle=ificle+1
  82. * write(6,*)' lfcdie ificle ' , ificle
  83. if(ificle.eq.10000)then
  84. call erreur (945)
  85. iretou=1
  86. return
  87. endif
  88. if(ificle.eq.1) then
  89. nomres(ll+1:ll+2)='_1'
  90. ll=ll+2
  91. elseif ( ificle.lt.10) then
  92. write(nomres(ll:ll),fmt='(I1)')ificle
  93. elseif ( ificle.lt.100) then
  94. if(ificle.eq.10)ll = ll + 1
  95. write(nomres(ll-1:ll),fmt='(I2)')ificle
  96. elseif ( ificle.lt.1000) then
  97. if(ificle.eq.100)ll = ll + 1
  98. write(nomres(ll-2:ll),fmt='(I3)')ificle
  99. elseif ( ificle.lt.10000) then
  100. if(ificle.eq.1000)ll = ll + 1
  101. write(nomres(ll-3:ll),fmt='(I4)')ificle
  102. endif
  103. if (iform.ne.2) close (unit=nband)
  104. if (iform.eq.2) ios=IXDRCLOSE( ixdrr)
  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.  
  118. 1000 IRETOU=1
  119. write (6,*) ' erreur lfcdie '
  120. RETURN
  121. 2000 continue
  122. MOTERR=NOMRES(1:ll)
  123. INTERR(1)=IOS
  124. CALL ERREUR(424)
  125. RETURN
  126. END
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  

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