Télécharger chiesp.eso

Retour à la liste

Numérotation des lignes :

  1. C CHIESP SOURCE CHAT 05/01/12 21:57:16 5004
  2. SUBROUTINE CHIESP(NVESP,IDSCHI)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C------------------------------------------------------------------
  6. C
  7. C PRISE EN COMPTE DE NOUVELLES ESPECES
  8. C
  9. C------------------------------------------------------------------
  10. -INC SMTABLE
  11. -INC SMLENTI
  12. -INC SMLREEL
  13. -INC CCOPTIO
  14. POINTEUR MLIDEN.MLENTI
  15. SEGMENT IDSCHI
  16. REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
  17. INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
  18. INTEGER IDECY(NYDIM),IONZ(NXDIM)
  19. CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
  20. ENDSEGMENT
  21. CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR
  22. CHARACTER*32 CHARM
  23. LOGICAL LOGRE
  24. INTEGER LINIT
  25. C
  26. NYDIM=IDY(/1)
  27. NXDIM=IDX(/1)
  28. NZDIM=IDZ(/1)
  29. NPDIM=IDP(/1)
  30. MTAB1=NVESP
  31. SEGACT MTAB1
  32. NNESP= MTAB1.MLOTAB
  33. C WRITE(6,*)'CHIESP',NNESP
  34. NBIESP=NNESP
  35. IVALI=0
  36. XVALI=0.D0
  37. IRETI=0
  38. IVALR=0
  39. XVALR=0.D0
  40. IRETR=0
  41. MTYPI='MOT '
  42. MTYPR=' '
  43. CHARR=' '
  44. CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'CLASSE',.TRUE.,IRETI,
  45. * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  46. IF(IERR.NE.0)RETURN
  47. SEGACT MTAB1
  48. IF(MTYPR.EQ.'MOT ')THEN
  49. C on a trouvé CLASSE c'est un objet on va compter les indices entier
  50. NBIESP= 0
  51. DO 5 IESP=1,NNESP
  52. C write(6,*)' chiesp',mtabti(iesp),mtabtv(iesp),RMTABI(iesp),
  53. C * MTABII(iesp),MTABIV(iesp),RMTABV(iesp)
  54. IF((MTAB1.MTABTI(IESP)).EQ.'ENTIER') NBIESP= NBIESP+1
  55. 5 CONTINUE
  56. ENDIF
  57. DO 80 IESP=1,NBIESP
  58. IVALI=IESP
  59. XVALI=0.D0
  60. IRETI=0
  61. IVALR=0
  62. XVALR=0.D0
  63. IRETR=0
  64. MTYPI='ENTIER '
  65. MTYPR=' '
  66. CHARR=' '
  67. CHARI=' '
  68. CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,CHARI,.TRUE.,IRETI,
  69. * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  70. IF(IERR.NE.0)RETURN
  71. SEGACT MTAB1
  72. IF((MTYPR.EQ.'TABLE ').OR.(MTYPR.EQ.'OBJET '))THEN
  73. MTAB2=IRETR
  74. SEGACT MTAB2
  75. IVALI=1
  76. XVALI=0.D0
  77. IRETI=0
  78. IVALR=0
  79. XVALR=0.D0
  80. IRETR=0
  81. MTYPI='MOT '
  82. MTYPR='ENTIER '
  83. CHARR=' '
  84. CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'IDEN',.TRUE.,IRETI,
  85. * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  86. IF(IERR.NE.0)RETURN
  87. SEGACT MTAB1
  88. IDESP=IVALR
  89. IVALI=1
  90. XVALI=0.D0
  91. IRETI=0
  92. IVALR=0
  93. XVALR=0.D0
  94. IRETR=0
  95. MTYPI='MOT '
  96. MTYPR='FLOTTANT'
  97. CHARR=' '
  98. CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'LOGK',.TRUE.,IRETI,
  99. * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  100. IF(IERR.NE.0)RETURN
  101. SEGACT MTAB1
  102. GKESP=XVALR
  103. IVALI=1
  104. XVALI=0.D0
  105. IRETI=0
  106. IVALR=0
  107. XVALR=0.D0
  108. IRETR=0
  109. MTYPI='MOT '
  110. MTYPR=' '
  111. CHARR=' '
  112. CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'COMP',.TRUE.,
  113. * IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  114. SEGACT MTAB1
  115. IF(MTYPR.EQ.' ')THEN
  116. CALL CHIADY(IDY,NYDIM,IDESP,K)
  117. IF(K.EQ.0) THEN
  118. C WRITE(6,*)' MODIF LOGK DE L ESPECE ',IDESP,' IMPOSSIBLE'
  119. C WRITE(6,*)' CETTE ESPECE N A PAS ÉTÉ RETENUE '
  120. MOTERR(1:40)='********** NVESP . LOGK '
  121. CALL ERREUR(-301)
  122. INTERR(1)=IDESP
  123. CALL ERREUR(776)
  124. RETURN
  125. ENDIF
  126. GK(K)=GKESP
  127. ELSEIF(MTYPR.EQ.'LISTENTI')THEN
  128. MLENTI=IRETR
  129. SEGACT MLENTI
  130. CALL CHIADY(IDY,NYDIM,IDESP,K)
  131. IF(K.NE.0) THEN
  132. C WRITE(6,*)' L ESPECE ',IDESP,' EXISTE DEJA '
  133. INTERR(1)=IDESP
  134. CALL ERREUR(777)
  135. RETURN
  136. ENDIF
  137. IVALI=1
  138. XVALI=0.D0
  139. IRETI=0
  140. IVALR=0
  141. XVALR=0.D0
  142. IRETR=0
  143. MTYPI='MOT '
  144. MTYPR='ENTIER '
  145. CHARR=' '
  146. CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'ITYP',.TRUE.,IRETI,
  147. * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  148. IF(IERR.NE.0)RETURN
  149. SEGACT MTAB1
  150. ITJP=IVALR
  151. IVALI=1
  152. XVALI=0.D0
  153. IRETI=0
  154. IVALR=0
  155. XVALR=0.D0
  156. IRETR=0
  157. MTYPI='MOT '
  158. MTYPR='LISTREEL'
  159. CHARR=' '
  160. CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'STOECH',.TRUE.,
  161. * IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  162. IF(IERR.NE.0)RETURN
  163. SEGACT MTAB1
  164. MLREEL=IRETR
  165. SEGACT MLREEL
  166. IVALI=1
  167. XVALI=0.D0
  168. IRETI=0
  169. IVALR=0
  170. XVALR=0.D0
  171. IRETR=0
  172. MTYPI='MOT '
  173. MTYPR=' '
  174. CHARM=' '
  175. CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'NOMESPECE',.TRUE.,IRETI,
  176. * MTYPR,IVALR,XVALR,CHARM,LOGRE,IRETR)
  177. IF(IERR.NE.0)RETURN
  178. SEGACT MTAB1
  179. C
  180. C ON TRAITE
  181. C
  182. C WRITE(6,*)'CHIESP ',IDESP,ITJP,GKESP,MLENTI,MLREEL
  183. LB=LECT(/1)
  184. LC=PROG(/1)
  185. IF(LB.NE.LC)THEN
  186. MOTERR(1:40)='********** NVESP . STOECH '
  187. CALL ERREUR(-301)
  188. CALL ERREUR(21)
  189. RETURN
  190. ENDIF
  191. *** VERIF COMPOSITION
  192. DO 20 L=1,LB
  193. IF(LECT(L).NE.0) THEN
  194. IDCK = LECT(L)
  195. CALL CHIADY(IDX,NXDIM,IDCK,K)
  196. IF(K.EQ.0) THEN
  197. C WRITE(6,*)' LE COMPOSANT ',IDCK,' N A PAS ÉTÉ RETENU'
  198. C WRITE(6,*)' LE COMPLEXE ',IDESP,' NE PEUT ETRE FORMÉ '
  199. MOTERR(1:40)='************ NVESP . COMP '
  200. CALL ERREUR(-301)
  201. INTERR(1)=IDCK
  202. CALL ERREUR(776)
  203. RETURN
  204. ENDIF
  205. ELSE
  206. GOTO 30
  207. ENDIF
  208. 20 CONTINUE
  209. *** INSERTION
  210. 30 CONTINUE
  211. NN(6)=NN(6)+1
  212. NYDIM=NYDIM+1
  213. SEGADJ IDSCHI
  214. IDY(NYDIM)=IDESP
  215. DO 40 IX=1,LB
  216. IF(LECT(IX).EQ.0) GO TO 50
  217. IDCK = LECT(IX)
  218. CALL CHIADY(IDX,NXDIM,IDCK,IK)
  219. AA(NYDIM,IK)=PROG(IX)
  220. GK(NYDIM) =GKESP
  221. NAMESP(NYDIM)=CHARM
  222. 40 CONTINUE
  223. 50 CONTINUE
  224. * WRITE(6,*)' IDJP ',IDJP,' ITJP ',ITJP
  225. LINIT=6
  226. CALL CHIREX(IDSCHI,IDESP,LINIT,ITJP )
  227. IF(ITJP.NE.2)THEN
  228. NPDIM=NPDIM+1
  229. SEGADJ IDSCHI
  230. IDP(NPDIM)=IDESP
  231. ENDIF
  232. SEGDES MLENTI,MLREEL
  233. ELSE
  234. MOTERR(1:11)='COMP '
  235. MOTERR(12:20)='LISTENTI'
  236. CALL ERREUR(627)
  237. RETURN
  238. ENDIF
  239. SEGDES MTAB2
  240. ELSE
  241. MOTERR(1:40)='******** NVESP ??????????? '
  242. CALL ERREUR(-301)
  243. CALL ERREUR(21)
  244. RETURN
  245. ENDIF
  246. 80 CONTINUE
  247. SEGDES MTAB1
  248. * WRITE(6,*)'IDX',(IDX(I),I=1,NXDIM)
  249. * WRITE(6,*)'IDY',(IDY(I),I=1,NYDIM)
  250. * write(6,*)'chiesp IDP',(idp(i),i=1,npdim)
  251. C WRITE(6,*)'GK',(GK(I),I=1,NYDIM)
  252. C WRITE(6,110)((AA(I,J),I=1,NYDIM),J=1,NXDIM)
  253. 110 FORMAT( 2X ,'AA',(10(1PE10.3)))
  254.  
  255.  
  256. RETURN
  257. END
  258.  
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  

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