Télécharger chmrex.eso

Retour à la liste

Numérotation des lignes :

  1. C CHMREX SOURCE CHAT 05/01/12 21:59:56 5004
  2. SUBROUTINE CHMREX(IDSCHI,IGKMOD,IGKTMP,ID,LINIT,LEND)
  3. C=======================================================================
  4. C ISSU DE TRIOEF (TREXTY)
  5. C PRISE EN COMPTE DE LA
  6. C TEMPERATURE (POUR BDD MINEQL ET POUR BDD STRASBOURG)
  7. C
  8. C OBJET: CHANGE LE TYPE D'ESPECE DE L'ESPECE ID
  9. C
  10. C ARGUMENTS:
  11. C IDSCHI =POINTEUR DU SEGMENT
  12. C IGKMOD= POINTEUR DU SEGMENT CONTENANT LES DONNEES TEMPERATURE
  13. C IGKTMP
  14. C LGKMOD POUR MINEQL
  15. C LGKTMP POUR STRASBOURG
  16. C ID =N› DE L'ESPECE CONCERNE, APPARTIENT AU TABLEAU IDY
  17. C LINIT =TYPE D'ESPECE ACTUEL
  18. C LEND =TYPE D'ESPECE FINAL
  19. C
  20. C
  21. C CETTE SUBROUTINE MODIFIE CERTAIN TABLEAUX CONCERNANT LES ESPECES,
  22. C TELS QUE NN, IDY, ETC...
  23. C
  24. C======================================================================
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8(A-H,O-Z)
  27. SEGMENT IDSCHI
  28. REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM)
  29. INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6)
  30. INTEGER IDECY(NYDIM),IONZ(NXDIM)
  31. CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM)
  32. ENDSEGMENT
  33. SEGMENT LGKMOD
  34. REAL*8 DELH0(NYDIM),DELCP0(NYDIM)
  35. ENDSEGMENT
  36. SEGMENT LGKTMP
  37. INTEGER NUMT(NYDIM),NTVT(NYDIM)
  38. REAL*8 TMIMA(NYDIM,NT)
  39. REAL*8 POLYT(NYDIM,NT4),TGKLU(NYDIM,NT)
  40. ENDSEGMENT
  41. SEGMENT IBID
  42. REAL*8 TLU(NT4)
  43. ENDSEGMENT
  44. CHARACTER*32 NAMINT
  45. C
  46.  
  47. C
  48. * WRITE(6,*)' ID',ID,'LINIT',LINIT,'LEND',LEND
  49.  
  50. IF (LINIT.EQ.LEND) RETURN
  51. NXDIM=IDX(/1)
  52. NYDIM=IDY(/1)
  53. NZDIM=IDZ(/1)
  54. NPDIM=IDP(/1)
  55. CALL CHIADY(IDY,NYDIM,ID,IJ)
  56. IF(IJ.EQ.0)CALL ERREUR(21)
  57. C
  58. K=1
  59. II=0
  60. C
  61. DO 940 LL=1,LINIT
  62. 940 II=II+NN(LL)
  63. III=II-NN(LINIT)+1
  64. * WRITE(6,*)' II ',II,' III ',III,' IJ',IJ,' CHMREX '
  65. IF (IJ.LT.III.OR.IJ.GT.II) THEN
  66. CALL ERREUR(22)
  67. RETURN
  68. ENDIF
  69. IF (LEND.LE.LINIT) THEN
  70. K=-1
  71. II=III
  72. ENDIF
  73. C
  74. NN(LINIT)=NN(LINIT)-1
  75. NN(LEND)=NN(LEND)+1
  76. LINIT2= LINIT+K
  77. IJDD= IJ
  78. IIDD= II
  79. DO 930 LL= LINIT2,LEND,K
  80. C
  81. C ANCIEN CALL TREXROW(SP1,SP2,LOGKMOD,I,II)
  82. C
  83. I0=IJ
  84. IV=IDY(II)
  85. IDY(II)=IDY(I0)
  86. IDY(I0)=IV
  87. IV=IDECY(II)
  88. IDECY(II)=IDECY(I0)
  89. IDECY(I0)=IV
  90. * WRITE(6,*) '------ IDY(I0): ',IDY(I0)
  91. DO 46 J=1,NXDIM
  92. V=AA(I0,J)
  93. AA(I0,J)=AA(II,J)
  94. AA(II,J)=V
  95. 46 CONTINUE
  96. V=GK(I0)
  97. GK(I0)=GK(II)
  98. GK(II)=V
  99. NAMINT=NAMESP(I0)
  100. NAMESP(I0)=NAMESP(II)
  101. NAMESP(II)=NAMINT
  102. IJ=II
  103. II=II+K*NN(LL)
  104. 930 CONTINUE
  105. C
  106. C
  107. IF(IGKMOD.GT.0)THEN
  108. LGKMOD=IGKMOD
  109. IJ= IJDD
  110. II= IIDD
  111. DO 950 LL= LINIT2,LEND,K
  112. I0=IJ
  113. V=DELH0(I0)
  114. DELH0(I0)=DELH0(II)
  115. DELH0(II)=V
  116. V=DELCP0(I0)
  117. DELCP0(I0)=DELCP0(II)
  118. DELCP0(II)=V
  119. IJ=II
  120. II=II+K*NN(LL)
  121. 950 CONTINUE
  122. ENDIF
  123. C
  124. C
  125. IF(IGKTMP.GT.0)THEN
  126. LGKTMP=IGKTMP
  127. NT=TGKLU(/2)
  128. NT4=NT*4
  129. SEGINI IBID
  130. IJ= IJDD
  131. II= IIDD
  132. DO 960 LL= LINIT2,LEND,K
  133. I0=IJ
  134. JI=NTVT(I0)
  135. NTVT(I0)=NTVT(II)
  136. NTVT(II)=JI
  137. JI=NUMT(I0)
  138. NUMT(I0)=NUMT(II)
  139. NUMT(II)=JI
  140. DO 13 IK=1,NT
  141. TLU(IK)=TMIMA(I0,IK)
  142. TMIMA(I0,IK)=TMIMA(II,IK)
  143. TMIMA(II,IK)=TLU(IK)
  144. 13 CONTINUE
  145. DO 11 IK=1,NT
  146. TLU(IK)=TGKLU(I0,IK)
  147. TGKLU(I0,IK)=TGKLU(II,IK)
  148. TGKLU(II,IK)=TLU(IK)
  149. 11 CONTINUE
  150. DO 12 IK=1,NT*4
  151. TLU(IK)=POLYT(I0,IK)
  152. POLYT(I0,IK)=POLYT(II,IK)
  153. POLYT(II,IK)=TLU(IK)
  154. 12 CONTINUE
  155. C
  156. C FIN DE TREXROW SOURCE
  157. IJ=II
  158. II=II+K*NN(LL)
  159. 960 CONTINUE
  160. SEGSUP IBID
  161. ENDIF
  162. RETURN
  163. END
  164.  
  165.  
  166.  
  167.  

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