Télécharger openrb.eso

Retour à la liste

Numérotation des lignes :

  1. C OPENRB SOURCE JC220346 13/12/16 21:16:06 7884
  2. C SORMAT SOURCE JC220346 12/06/18 21:15:25 7403
  3. ************************************************************************
  4. * NOM : openrb.eso
  5. * DESCRIPTION : Ouverture d'un fichier au format RUTHERFORD BOEING (.rb)
  6. * REFERENCES : The Rutherford-Boeing Sparse Matrix Collection,
  7. * Duff I. S., Grimes R. G., Lewis G. L. (Sep 1997)
  8. ************************************************************************
  9. * HISTORIQUE : 4/12/2012 : JCARDO : création de la subroutine
  10. * HISTORIQUE :
  11. * HISTORIQUE :
  12. ************************************************************************
  13. * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
  14. * en cas de modification de ce sous-programme afin de faciliter
  15. * la maintenance !
  16. ************************************************************************
  17. * APPELÉ PAR : sormat.eso
  18. ************************************************************************
  19.  
  20. SUBROUTINE OPENRB(CHNOMF,CHTYPE,CHTITR,
  21. & IVA1,IVA2,IVA3,IVA4,IVA5,IVA6,IVA7,IVA8,
  22. & CVA1,CVA2,CVA3,CVA4)
  23.  
  24. * | Fichier matrice | Fichier auxiliaire |
  25. * --------+-----------------------+----------------------+
  26. * IVA1 | TOTCRD | M |
  27. * IVA2 | PTRCRD | NVEC |
  28. * IVA3 | INDCRD | NAUXD |
  29. * IVA4 | VALCRD | |
  30. * IVA5 | NROW ou MVAR | |
  31. * IVA6 | NCOL ou NELT | |
  32. * IVA7 | NNZERO ou NVARIX | |
  33. * IVA8 | NELTVL | |
  34. * --------+-----------------------+----------------------+
  35. * CVA1 | MXTYPE | DATTYP+POSITN+ORGNIZ |
  36. * | | +CASEID+NUMERF |
  37. * CVA2 | PTRFMT | AUXFM1 |
  38. * CVA3 | INDFMT | AUXFM2 |
  39. * CVA4 | VALFMT | AUXFM3 |
  40. *
  41.  
  42. IMPLICIT INTEGER(I-N)
  43. IMPLICIT REAL*8(A-H,O-Z)
  44.  
  45. EXTERNAL LONG
  46.  
  47.  
  48. -INC PPARAM
  49. -INC CCOPTIO
  50.  
  51. CHARACTER*(*) CHNOMF,CHTYPE,CHTITR,CVA1,CVA2,CVA3,CVA4
  52.  
  53. CHARACTER*8 NOMFUC,NOMFLC
  54. CHARACTER*256 CHDIRF
  55. CHARACTER*8 CHA8
  56.  
  57. CHARACTER*26 MINUSC,MAJUSC
  58. CHARACTER*11 MDIGIT
  59. CHARACTER*63 MCHARS
  60. PARAMETER (MINUSC='abcdefghijklmnopqrstuvwxyz')
  61. PARAMETER (MAJUSC='ABCDEFGHIJKLMNOPQRSTUVWXYZ')
  62. PARAMETER (MDIGIT='0123456789_')
  63. PARAMETER (MCHARS=MINUSC//MAJUSC//MDIGIT)
  64.  
  65.  
  66. * VERIFICATION DU NOM
  67. * ===================
  68.  
  69. * On récupère le nom du répertoire dans NOM1, s'il existe
  70. IREP=INDEX(CHNOMF,'/',BACK=.TRUE.)
  71. CHDIRF='./'
  72. IF (IREP.GT.0) THEN
  73. CHDIRF=CHNOMF(1:IREP)
  74. CHNOMF=CHNOMF(IREP+1:LONG(CHNOMF))
  75. ENDIF
  76.  
  77. * Longueur du nom du fichier
  78. LC=LONG(CHNOMF)
  79. IF (LC.GT.8) THEN
  80. WRITE(*,*) 'le nom doit faire 8 char. max'
  81. MOTERR(1:8)=CHNOMF(1:5)//'...'
  82. CALL ERREUR(705)
  83. RETURN
  84. ENDIF
  85. MOTERR=CHNOMF
  86.  
  87. * Conversion en majuscules/minuscules
  88. NOMFUC=CHNOMF
  89. NOMFLC=CHNOMF
  90. DO K=1,LC
  91. IC=INDEX(MCHARS,CHNOMF(K:K))
  92. IF (IC.EQ.0) THEN
  93. WRITE(*,*) 'le nom contient des caracteres interdits'
  94. CALL ERREUR(705)
  95. RETURN
  96. ENDIF
  97. IF (IC.LE.26) THEN
  98. NOMFUC(K:K)=MAJUSC(IC:IC)
  99. ELSEIF (IC.LE.52) THEN
  100. ID=IC-26
  101. NOMFLC(K:K)=MINUSC(ID:ID)
  102. ENDIF
  103. ENDDO
  104.  
  105. * Le premier caractère ne peut pas être un _
  106. IF (NOMFUC(1:1).EQ.'_') THEN
  107. WRITE(*,*) 'le premier caractère doit etre alphanumerique'
  108. CALL ERREUR(705)
  109. RETURN
  110. ENDIF
  111.  
  112.  
  113.  
  114. * OUVERTURE DU FICHIER
  115. * ====================
  116.  
  117. OPEN(UNIT = IOPER ,
  118. & STATUS = 'UNKNOWN' ,
  119. & FILE = CHDIRF(1:LONG(CHDIRF))//CHNOMF(1:LC)//'.'//
  120. & CHTYPE(1:LONG(CHTYPE))//'.rb' ,
  121. & IOSTAT = IOS ,
  122. & FORM = 'FORMATTED' )
  123.  
  124.  
  125.  
  126. * ÉCRITURE DE L'ENTETE
  127. * ====================
  128.  
  129. * Ligne 1 : TITLE + MTRXID
  130. WRITE(UNIT=IOPER,FMT='(A71,A8)')
  131. .CHTITR(1:71),
  132. .NOMFUC(1:LC)
  133.  
  134.  
  135. IF (CHTYPE.EQ.'mtx') THEN
  136.  
  137. * Ligne 2 : TOTCRD + PTRCRD + INDCRD + VALCRD
  138. WRITE(IOPER,FMT='(I14,3(1X,I13))')
  139. & IVA1,IVA2,IVA3,IVA4
  140.  
  141. * Ligne 3 : MXTYPE NROW NCOL NNZERO
  142. * ou MXTYPE MVAR NELT NVARIX NELTVL
  143. WRITE(IOPER,FMT='(A3,11X,4(1X,I13))')
  144. & CVA1(1:3),IVA5,IVA6,IVA7,IVA8
  145.  
  146. * Ligne 4 : PTRFMT + INDFMT + VALFMT
  147. WRITE(IOPER,FMT='(2A16,A20)')
  148. & CVA2,CVA3,CVA4
  149.  
  150. ELSE
  151.  
  152. * Ligne 2 : DATTYP/POSITN/ORGNIZ/CASEID/NUMERF + M + NVEC + NAUXD
  153. WRITE(IOPER,FMT='(A5,1X,A8,1X,A1,3(1X,I13))')
  154. & CVA1(1:5),CVA1(6:13),CVA1(14:14),IVA1,IVA2,IVA3
  155.  
  156. * Ligne 3 : AUXFM1 + AUXFM2 + AUXFM3
  157. WRITE(IOPER,FMT='(3A20)')
  158. & CVA2,CVA3,CVA4
  159.  
  160. ENDIF
  161.  
  162.  
  163.  
  164. RETURN
  165.  
  166. END
  167.  
  168.  

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