Télécharger ecbase.eso

Retour à la liste

Numérotation des lignes :

  1. C ECBASE SOURCE CHAT 05/01/12 23:20:09 5004
  2. SUBROUTINE ECBASE(MBASEM)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C====================================================================
  6. C ECRITURE D UNE BASE MODALE
  7. C ECRIT PAR FARVACQUE
  8. C N'APPELLE AUCUN SUBROUTINE
  9. C=====================================================================
  10. -INC SMBASEM
  11. -INC SMELEME
  12. -INC SMSOLUT
  13. -INC SMATTAC
  14. -INC CCOPTIO
  15. DIMENSION ILIA(5)
  16. CHARACTER*4 MLIA(5)
  17. DATA MLIA/'MECA','FLUI','DEPI','CHOC','DEVE'/
  18. DATA NLIA/5/
  19. INTERR(1)=MBASEM
  20. CALL ERREUR(-97)
  21. SEGACT MBASEM
  22. NBASE=LISBAS(/1)
  23. DO 100 IB=1,NBASE
  24. MSOBAS=LISBAS(IB)
  25. SEGACT MSOBAS
  26. IBSTRU=IBSTRM(1)
  27. IBMODE=IBSTRM(2)
  28. IBSOLS=IBSTRM(3)
  29. IBMATT=IBSTRM(4)
  30. IBPSEU=IBSTRM(5)
  31. INTERR(1)=IB
  32. INTERR(2)=MSOBAS
  33. CALL ERREUR(-98)
  34. C
  35. IF(IBMODE.EQ.0) GO TO 1
  36. INTERR(1)=IBMODE
  37. MOTERR(1:8)=' MODE '
  38. CALL ERREUR(-99)
  39. MSOLUT=IBMODE
  40. SEGACT MSOLUT
  41. MSOLEN=MSOLIS(4)
  42. MELEME=MSOLIS(3)
  43. SEGACT MSOLEN, MELEME
  44. NMOD=ISOLEN(/1)
  45. DO 10 IM=1,NMOD
  46. MMODE=ISOLEN(IM)
  47. SEGACT MMODE
  48. IP1=NUM(1,IM)
  49. WRITE(IOIMP,3006) IP1,FMMODD(1)
  50. SEGDES MMODE
  51. 10 CONTINUE
  52. SEGDES MSOLEN,MSOLUT,MELEME
  53. WRITE(IOIMP,3003)
  54. C
  55. 1 CONTINUE
  56. IF(IBSOLS.EQ.0) GO TO 2
  57. MOTERR(1:8)='SOLUSTAT'
  58. INTERR(1)=IBSOLS
  59. CALL ERREUR(-99)
  60. MSOLUT=IBSOLS
  61. SEGACT MSOLUT
  62. MELEME=MSOLIS(3)
  63. MSOLEN=MSOLIS(4)
  64. MSOLE1=MSOLIS(10)
  65. SEGACT MSOLEN, MELEME
  66. IF(MSOLE1.NE.0) SEGACT MSOLE1
  67. NMOD=ISOLEN(/1)
  68. DO 40 IM=1,NMOD
  69. MMODE=ISOLEN(IM)
  70. SEGACT MMODE
  71. IP1=NUM(1,IM)
  72. IF(MSOLE1.NE.0) THEN
  73. WRITE(IOIMP,3007) IP1,FMMODD(1),MSOLE1.ISOLEN(IM)
  74. ELSE
  75. WRITE(IOIMP,3006) IP1,FMMODD(1)
  76. ENDIF
  77. SEGDES MMODE
  78. 40 CONTINUE
  79. SEGDES MSOLEN,MSOLUT,MELEME
  80. IF(MSOLE1.NE.0) SEGDES MSOLE1
  81. WRITE(IOIMP,3003)
  82. C
  83. 2 CONTINUE
  84. IF(IBPSEU.EQ.0) GO TO 3
  85. INTERR(1)=IBPSEU
  86. MOTERR(1:8)='PSEUMODE'
  87. CALL ERREUR(-99)
  88. MSOLUT=IBPSEU
  89. SEGACT MSOLUT
  90. MELEME=MSOLIS(3)
  91. MSOLEN=MSOLIS(4)
  92. MSOLE1=MSOLIS(10)
  93. SEGACT MSOLEN, MELEME
  94. IF(MSOLE1.NE.0) SEGACT MSOLE1
  95. NMOD=ISOLEN(/1)
  96. DO 50 IM=1,NMOD
  97. MMODE=ISOLEN(IM)
  98. SEGACT MMODE
  99. IP1=NUM(1,IM)
  100. IF(MSOLE1.NE.0) THEN
  101. WRITE(IOIMP,3007) IP1,FMMODD(1),MSOLE1.ISOLEN(IM)
  102. ELSE
  103. WRITE(IOIMP,3006) IP1,FMMODD(1)
  104. ENDIF
  105. SEGDES MMODE
  106. 50 CONTINUE
  107. SEGDES MSOLEN,MSOLUT,MELEME
  108. IF(MSOLE1.NE.0) SEGDES MSOLE1
  109. WRITE(IOIMP,3003)
  110. C
  111. 3 CONTINUE
  112. IF(IBMATT.EQ.0) GO TO 4
  113. MATTAC=IBMATT
  114. INTERR(1)=IBMATT
  115. CALL ERREUR(-100)
  116. WRITE(IOIMP,3003)
  117. SEGACT MATTAC
  118. DO 33 IL=1,NLIA
  119. ILIA(IL)=0
  120. 33 CONTINUE
  121. DO 30 ISOU=1,LISATT(/1)
  122. MSOUMA=LISATT(ISOU)
  123. SEGACT MSOUMA
  124. DO 31 IL=1,NLIA
  125. IF(ITYATT.EQ.MLIA(IL))ILIA(IL)=ILIA(IL)+1
  126. 31 CONTINUE
  127. SEGDES MSOUMA
  128. 30 CONTINUE
  129. DO 32 IL=1,NLIA
  130. IF(ILIA(IL).NE.0) THEN
  131. INTERR(1)=ILIA(IL)
  132. MOTERR(1:4)=MLIA(IL)
  133. CALL ERREUR(-101)
  134. ENDIF
  135. 32 CONTINUE
  136. SEGDES MATTAC
  137. C
  138. 4 CONTINUE
  139. SEGDES MSOBAS
  140. 100 CONTINUE
  141. C
  142. SEGDES MBASEM
  143. RETURN
  144. C
  145. 3003 FORMAT(1X,67('*'))
  146. 3006 FORMAT(' *',10X,'*',10X,'*',10X,'* ',I5,' * ',E12.5,' *',9X,'*')
  147. 3007 FORMAT(' *',10X,'*',10X,'*',10X,'* ',I5,' * ',E12.5,' * ',I5,
  148. 1' *')
  149. C
  150. END
  151.  
  152.  

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