Télécharger lfcdi2.eso

Retour à la liste

Numérotation des lignes :

  1. C LFCDI2 SOURCE CHAT 08/09/18 21:15:04 6162
  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(1)
  8. external long
  9. ipas=0
  10. 10 IRETOU=0
  11. ios=1
  12. IF (LMAX.EQ.0) GO TO 1
  13. IF(IONIVE.GT.2) THEN
  14. IF (IFORM.EQ.1) READ(NBAND,8003,END=1001,ERR=1000)
  15. # (R(I),I=1,LMAX)
  16. IF (IFORM.EQ.0) READ(NBAND,END=1001,ERR=1000) (R(I),I=1,LMAX)
  17. ELSE
  18. IF (IFORM.EQ.1) READ(NBAND,8002,END=1001,ERR=1000)
  19. # (R(I),I=1,LMAX)
  20. IF (IFORM.EQ.0) READ(NBAND,END=1001,ERR=1000) (R(I),I=1,LMAX)
  21. ENDIF
  22. if (iform.eq.2) ios=IXDRDMAT( ixdrr, lmax,r(1))
  23. * write (6,*) ' ios dans lfcdi2 ',ios
  24. if (ios.lt.0) goto 1001
  25. GO TO 1
  26. 1000 IRETOU=1
  27. 1 RETURN
  28. 1001 ll=long (nomres)
  29. ificle=ificle+1
  30. * write(6,*)' ificle ' , ificle
  31. if(ificle.eq.10000)then
  32. call erreur (945)
  33. iretou=1
  34. return
  35. endif
  36. if(ificle.eq.1) then
  37. nomres(ll+1:ll+2)='_1'
  38. ll=ll+2
  39. elseif ( ificle.lt.10) then
  40. write(nomres(ll:ll),fmt='(I1)')ificle
  41. elseif ( ificle.lt.100) then
  42. if(ificle.eq.10)ll = ll + 1
  43. write(nomres(ll-1:ll),fmt='(I2)')ificle
  44. elseif ( ificle.lt.1000) then
  45. if(ificle.eq.100)ll = ll + 1
  46. write(nomres(ll-2:ll),fmt='(I3)')ificle
  47. elseif ( ificle.lt.10000) then
  48. if(ificle.eq.1000)ll = ll + 1
  49. write(nomres(ll-3:ll),fmt='(I4)')ificle
  50. endif
  51. if (iform.ne.2) close (unit=nband)
  52. if (iform.eq.2) ios=IXDRCLOSE( ixdrr )
  53. * write(6,*) ' fermeture et ouverture de ',nomres(1:ll)
  54. if(iform.eq.1) then
  55. OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMRES(1:ll),
  56. # IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  57. ELSEif (iform.eq.0) then
  58. OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMRES(1:ll),
  59. # IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
  60. else
  61. ios=INITXDR( NOMRES(1:ll),'r',.true.)
  62. if (ios.lt.0) goto 2000
  63. ENDIF
  64. write (6,*) 'Ouverture du fichier : ',nomres(1:ll)
  65. go to 10
  66. C --------------------
  67. 8002 FORMAT(1P,6E13.6)
  68. 8003 FORMAT(1P,3E22.14)
  69. 2000 MOTERR=NOMRES(1:ll)
  70. INTERR(1)=IOS
  71. CALL ERREUR(424)
  72. RETURN
  73. END
  74.  
  75.  
  76.  
  77.  
  78.  
  79.  
  80.  
  81.  
  82.  
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  

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