Télécharger lfdien.eso

Retour à la liste

Numérotation des lignes :

lfdien
  1. C LFDIEN SOURCE PV 21/07/07 21:15:01 11062
  2. SUBROUTINE LFDIEN(NBAND,SEGTAB,iretou,IFORM)
  3.  
  4. IMPLICIT INTEGER(I-N)
  5.  
  6. -INC PPARAM
  7. -INC CCOPTIO
  8. -INC CCFXDR
  9.  
  10. SEGMENT SEGTAB
  11. CHARACTER*(LCHAWR) ITAB(NM)
  12. ENDSEGMENT
  13.  
  14. C CFORMAT : Format pour lire en 'FORMAT' dans le fichier
  15. CHARACTER*12 CFORMAT
  16.  
  17. LCHAWR=SEGTAB.ITAB(/1)
  18. NM =SEGTAB.ITAB(/2)
  19.  
  20. IF (NM.EQ.0)RETURN
  21.  
  22. C Calcul du format des chaines
  23. CFORMAT='('
  24. IF(IONIVE .LT. 23)THEN
  25. CFORMAT='(16(1X,A4))'
  26. JCH=11
  27.  
  28. ELSE
  29. ICH=2
  30. IF (NM.GT.0 .AND. NM.LE.9 )THEN
  31. JCH=ICH
  32. WRITE(CFORMAT(ICH:JCH) ,FMT='(I1)') NM
  33. ELSEIF(NM.GT.9 .AND. NM.LE.99 )THEN
  34. ICH=2
  35. JCH=ICH+1
  36. WRITE(CFORMAT(ICH:JCH) ,FMT='(I2)') NM
  37. ELSEIF(NM.GT.99 .AND. NM.LE.999)THEN
  38. ICH=3
  39. JCH=ICH+2
  40. WRITE(CFORMAT(ICH:JCH) ,FMT='(I3)') NM
  41. ELSE
  42. PRINT*,'ECDIEN.ESO-Valeur de NM:',NM
  43. CALL ERREUR(5)
  44. ENDIF
  45. ICH=ICH+1
  46. CFORMAT(ICH:ICH+4)='(1X,A'
  47.  
  48. ICH=ICH+5
  49. IF (LCHAWR.GT.0 .AND. LCHAWR.LE.9 )THEN
  50. JCH=ICH
  51. WRITE(CFORMAT(ICH:JCH) ,FMT='(I1)') LCHAWR
  52.  
  53. ELSEIF(LCHAWR.GT.9 .AND. LCHAWR.LE.99 )THEN
  54. JCH=ICH+1
  55. WRITE(CFORMAT(ICH:JCH) ,FMT='(I2)') LCHAWR
  56. CFORMAT(ICH+2:ICH+2)=')'
  57.  
  58. ELSEIF(LCHAWR.GT.99 .AND. LCHAWR.LE.999)THEN
  59. JCH=ICH+2
  60. WRITE(CFORMAT(ICH:JCH),FMT='(I3)') LCHAWR
  61. CFORMAT(ICH+3:ICH+3)=')'
  62.  
  63. ELSE
  64. PRINT*,'ECDIEN.ESO-Valeur de LCHAWR:',LCHAWR
  65. CALL ERREUR(5)
  66. ENDIF
  67.  
  68. ICH=JCH+1
  69. JCH=ICH+1
  70. CFORMAT(ICH:JCH)='))'
  71. ENDIF
  72. iretou=0
  73. IF (IFORM.EQ.1)read(NBAND,FMT=CFORMAT,err=1000)(ITAB(I),I=1,NM)
  74. IF (IFORM.EQ.0)read(NBAND,err=1000) (ITAB(I),I=1,NM)
  75. if (iform.eq.2)then
  76. ios=IXDRSTRING(ixdrr,itab(1)(1:LCHAWR*NM))
  77. iretou=ios
  78. endif
  79.  
  80. RETURN
  81. 1000 continue
  82. iretou=1
  83. return
  84. END
  85.  
  86.  
  87.  

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