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. -INC CCOPTIO
  48.  
  49. CHARACTER*(*) CHNOMF,CHTYPE,CHTITR,CVA1,CVA2,CVA3,CVA4
  50.  
  51. CHARACTER*8 NOMFUC,NOMFLC
  52. CHARACTER*256 CHDIRF
  53. CHARACTER*8 CHA8
  54.  
  55. CHARACTER*26 MINUSC,MAJUSC
  56. CHARACTER*11 MDIGIT
  57. CHARACTER*63 MCHARS
  58. PARAMETER (MINUSC='abcdefghijklmnopqrstuvwxyz')
  59. PARAMETER (MAJUSC='ABCDEFGHIJKLMNOPQRSTUVWXYZ')
  60. PARAMETER (MDIGIT='0123456789_')
  61. PARAMETER (MCHARS=MINUSC//MAJUSC//MDIGIT)
  62.  
  63.  
  64. * VERIFICATION DU NOM
  65. * ===================
  66.  
  67. * On récupère le nom du répertoire dans NOM1, s'il existe
  68. IREP=INDEX(CHNOMF,'/',BACK=.TRUE.)
  69. CHDIRF='./'
  70. IF (IREP.GT.0) THEN
  71. CHDIRF=CHNOMF(1:IREP)
  72. CH^OMF<{p!n style="color: #339933;">=CHNOMF(IREP+1:LONG(CHNOMF))
  73. ENDIF
  74.  
  75. * Longueur du nom du fichier
  76. LC=LONG(CHNOMF)
  77. IF (LC.GT.8) THEN
  78. WRITE(*,*) 'le nom doit faire 8 char. max'
  79. MOTERR(1:8)=CHNOMF(1:5)//'...'
  80. CALL ERREUR(705)
  81. RETURN
  82. ENDIF
  83. MOTERR=CHNOMF
  84.  
  85. * Conversion en majuscules/minuscules
  86. NOMFUC=CHNOMF
  87. NOMFLC=CHNOMF
  88. DO K=1,LC
  89. IC=INDEX(MCHARS,CHNOMF(K:K))
  90. IF (IC.EQ.0) THEN
  91. WRITE(*,*) 'le nom contient des caracteres interdits'
  92. CALL ERREUR(705)
  93. RETURN
  94. ENDIF
  95. IF (IC.LE.26) THEN
  96. NOMFUC(K:K)=MAJUSC(IC:IC)
  97. ELSEIF (IC.LE.52) THEN
  98. ID=IC-26
  99. NOMFLC(K:K)=MINUSC(ID:ID)
  100. ENDIF
  101. ENDDO
  102.  
  103. * Le premier caractère ne peut pas être un _
  104. IF (NOMFUC(1:1).EQ.'_') THEN
  105. WRITE(*,*) 'le premier caractère doit etre alphanumerique'
  106. CALL ERREUR(705)
  107. RETURN
  108. ENDIF
  109.  
  110.  
  111.  
  112. * OUVERTURE DU FICHIER
  113. * ====================
  114.  
  115. OPEN(UNIT = IOPER ,
  116. & STATUS = 'UNKNOWN' ,
  117. & FILE = CHDIRF(1:LONG(CHDIRF))//CHNOMF(1:LC)//'.'//
  118. & CHTYPE(1:LONG(CHTYPE))//'.rb' ,
  119. & IOSTAT = IOS ,
  120. & FORM = 'FORMATTED' )
  121.  
  122.  
  123.  
  124. * ÉCRITURE DE L'ENTETE
  125. * ====================
  126.  
  127. * Ligne 1 : TITLE + MTRXID
  128. WRITE(UNIT=IOPER,FMT='(A71,A8)')
  129. .CHTITR(1:71),
  130. .NOMFUC(1:LC)
  131.  
  132.  
  133. IF (CHTYPE.EQ.'mtx') THEN
  134.  
  135. * Ligne 2 : TOTCRD + PTRCRD + INDCRD + VALCRD
  136. WRITE(IOPER,FMT='(I14,3(1X,I13))')
  137. & IVA1,IVA2,IVA3,IVA4
  138.  
  139. * Ligne 3 : MXTYPE NROW NCOL NNZERO
  140. * ou MXTYPE MVAR NELT NVARIX NELTVL
  141. WRITE(IOPER,FMT='(A3,11X,4(1X,I13))')
  142. & CVA1(1:3),IVA5,IVA6,IVA7,IVA8
  143.  
  144. * Ligne 4 : PTRFMT + INDFMT + VALFMT
  145. WRITE(IOPER,FMT='(2A16,A20)')
  146. & CVA2,CVA3,CVA4
  147.  
  148. ELSE
  149.  
  150. * Ligne 2 : DATTYP/POSITN/ORGNIZ/CASEID/NUMERF + M + NVEC + NAUXD
  151. WRITE(IOPER,FMT='(A5,1X,A8,1X,A1,3(1X,I13))')
  152. & CVA1(1:5),CVA1(6:13),CVA1(14:14),IVA1,IVA2,IVA3
  153.  
  154. * Ligne 3 : AUXFM1 + AUXFM2 + AUXFM3
  155. WRITE(IOPER,FMT='(3A20)')
  156. & CVA2,CVA3,CVA4
  157.  
  158. ENDIF
  159.  
  160.  
  161.  
  162. RETURN
  163.  
  164. END
  165.  
  166.  

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