Télécharger ecbase.eso

Retour à la liste

Numérotation des lignes :

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

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