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

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