Télécharger chicmp.eso

Retour à la liste

Numérotation des lignes :

  1. C CHICMP SOURCE CHAT 05/01/12 21:57:00 5004
  2. SUBROUTINE CHICMP(NVCOMP,IDSCHI)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C -------------------------------------------------------------------
  6. C
  7. C AJOUT DE NOUVELLES COMPOSANTES ( CHIMIE)
  8. C
  9. C -------------------------------------------------------------------
  10. -INC SMTABLE
  11. -INC SMLENTI
  12. POINTEUR MLIDEN.MLENTI,MLXMX.MLENTI
  13. -INC CCOPTIO
  14. SEGMENT IDSCHI
  15. REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
  16. INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
  17. INTEGER IDECY(NYDIM),IONZ(NXDIM)
  18. CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
  19. ENDSEGMENT
  20. CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR
  21. CHARACTER*32 CHARM
  22. LOGICAL LOGRE
  23. INTEGER LINIT
  24. C
  25. NYDIM=IDY(/1)
  26. NXDIM=IDX(/1)
  27. NZDIM=IDZ(/1)
  28. NPDIM=IDP(/1)
  29. MTAB1=NVCOMP
  30. SEGACT MTAB1
  31. NNCOMP= MTAB1.MLOTAB
  32. NICOMP=NNCOMP
  33. IVALI=0
  34. XVALI=0.D0
  35. IRETI=0
  36. IVALR=0
  37. XVALR=0.D0
  38. IRETR=0
  39. MTYPI='MOT '
  40. MTYPR=' '
  41. CHARR=' '
  42. CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'CLASSE',.TRUE.,IRETI,
  43. * MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  44. IF(IERR.NE.0)RETURN
  45. SEGACT MTAB1
  46. IF(MTYPR.EQ.'MOT ')THEN
  47. C
  48. C on a trouvé CLASSE c'est un OBJET on va compter les indices entier
  49. C
  50. NICOMP= 0
  51. DO 5 IESP=1,NNCOMP
  52. IF((MTAB1.MTABTI(IESP)).EQ.'ENTIER') NICOMP= NICOMP+1
  53. 5 CONTINUE
  54. ENDIF
  55. DO 50 ICOMP=1,NICOMP
  56. IVALI=ICOMP
  57. XVALI=0.D0
  58. IRETI=0
  59. IVALR=0
  60. XVALR=0.D0
  61. IRETR=0
  62. MTYPI='ENTIER '
  63. MTYPR=' '
  64. CHARR=' '
  65. CHARI=' '
  66. CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,CHARI,.TRUE.,IRETI,
  67. *MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  68. IF(IERR.NE.0)RETURN
  69. SEGACT MTAB1
  70. IF((MTYPR.EQ.'TABLE ').OR.(MTYPR.EQ.'OBJET ')) THEN
  71. MTAB2=IRETR
  72. SEGACT MTAB2
  73. NXDIM=NXDIM+1
  74. NYDIM=NYDIM+1
  75. SEGADJ IDSCHI
  76. IVALI=1
  77. XVALI=0.D0
  78. IRETI=0
  79. IVALR=0
  80. XVALR=0.D0
  81. IRETR=0
  82. MTYPI='MOT '
  83. MTYPR='ENTIER '
  84. CHARR=' '
  85. CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'IDEN',.TRUE.,IRETI,
  86. *MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  87. IF(IERR.NE.0)RETURN
  88. SEGACT MTAB1
  89. NVIDEN=IVALR
  90. IVALI=1
  91. XVALI=0.D0
  92. IRETI=0
  93. IVALR=0
  94. XVALR=0.D0
  95. IRETR=0
  96. MTYPI='MOT '
  97. MTYPR='MOT '
  98. CHARM=' '
  99. CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'NOM',.TRUE.,IRETI,
  100. * MTYPR,IVALR,XVALR,CHARM,LOGRE,IRETR)
  101. SEGACT MTAB1
  102. IF(IERR.NE.0)RETURN
  103. NAME(NXDIM)=CHARM
  104. IVALI=1
  105. XVALI=0.D0
  106. IRETI=0
  107. IVALR=0
  108. XVALR=0.D0
  109. IRETR=0
  110. MTYPI='MOT '
  111. MTYPR='ENTIER '
  112. CHARR=' '
  113. CALL ACCTAB(MTAB2,MTYPI,IVALI,XVALI,'CHARGE',.TRUE.,
  114. *IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR)
  115. IF(IERR.NE.0)RETURN
  116. SEGACT MTAB1
  117. IONZ(NXDIM)=IVALR
  118. NN(6)=NN(6)+1
  119. IDY(NYDIM)=NVIDEN
  120. LINIT=6
  121. CALL CHIREX(IDSCHI,NVIDEN,LINIT,1)
  122. AA(NN(1),NXDIM)=1.D0
  123. IDX(NXDIM)=NVIDEN
  124. GK(NN(1))=0.D0
  125. SEGDES MTAB2
  126. ELSE
  127. MOTERR(1:40)='******** NVCOMP ??????????? '
  128. CALL ERREUR(-301)
  129. CALL ERREUR(21)
  130. RETURN
  131. ENDIF
  132. 50 CONTINUE
  133. SEGDES MTAB1
  134. C WRITE(6,*)' FIN CHICMP NXDIM NYDIM' ,NXDIM,NYDIM
  135. C WRITE(6,*)(NAME(I),I=1,NXDIM)
  136. C WRITE(6,*)'IDX',(IDX(I),I=1,NXDIM)
  137. C WRITE(6,*)'IDY',(IDY(I),I=1,NYDIM)
  138. C WRITE(6,*)'GK',(GK(I),I=1,NYDIM)
  139. C WRITE(6,110)((AA(I,J),I=1,NYDIM),J=1,NXDIM)
  140. 110 FORMAT( 2X ,'AA',(10(1PE10.3)))
  141.  
  142.  
  143.  
  144. RETURN
  145. END
  146.  
  147.  
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  

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