Télécharger ryo2v.eso

Retour à la liste

Numérotation des lignes :

ryo2v
  1. C RYO2V SOURCE CB215821 20/11/25 13:39:35 10792
  2. SUBROUTINE RYO2V(IRT)
  3. C*************************************************************************
  4. C
  5. C
  6. C
  7. C
  8. C
  9. C*************************************************************************
  10.  
  11. IMPLICIT INTEGER(I-N)
  12. IMPLICIT REAL*8 (A-H,O-Z)
  13.  
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMTABLE
  18. -INC SMLMOTS
  19. -INC SMELEME
  20. POINTEUR MELEMC.MELEME
  21. -INC SMCOORD
  22.  
  23. POINTEUR MAT1.MATRIK,MAT2.MATRIK,MAT3.MATRIK
  24. -INC SMCHPOI
  25. C POINTEUR IZV1.MCHPOI,IZVV1.MPOVAL
  26. C POINTEUR IZV2.MCHPOI,IZVV2.MPOVAL
  27.  
  28. DIMENSION XVEC(3)
  29. CHARACTER*8 TYPE,TYPC,TYPE1,TYPE2
  30. LOGICAL LDMULT
  31. PARAMETER (NBOP=12)
  32. CHARACTER*4 MOT4
  33. CHARACTER*8 LOPER(NBOP),MTYP,NOMI
  34. DATA LOPER/'CMCT ','RIMA ','NINCDUPR','NINCPRDU',
  35. $ 'EXTRNINC',
  36. $ 'EXTRINCO','POINTEUR','EXTRDIAG','SPAIDIAG','RELA ',
  37. $ 'CONDENSE','EVAPORE '/
  38. C***
  39. C ********************************************
  40. C * La premiere partie de cette routine *
  41. C * consiste a recuperer les arguments de *
  42. C * l operateur KOPS afin de pouvoir leurs *
  43. C * attribuer le traitement correspondant *
  44. C ********************************************
  45.  
  46. C On saisit le premier objet de la pile
  47. C *************************************
  48.  
  49. CALL QUETYP(MTYP,0,IRET)
  50. IF(IRET.EQ.0)THEN
  51. IRT=1
  52. RETURN
  53. ENDIF
  54. C write(6,*)' KOPS nag=',nag,' MTYP=',MTYP
  55.  
  56. C ============================================
  57. C Cas : Objet = MOT
  58. C ============================================
  59. IRT=0
  60. IF(MTYP.NE.'MOT')THEN
  61. IRT=1
  62. RETURN
  63. ELSE
  64. CALL LIRMOT(LOPER,NBOP,KOP,1)
  65. C write(6,*)' KOPS ', LOPER(KOP)
  66. C write(6,*) 'Avant KOPS ', LOPER(KOP)
  67. IF(KOP.EQ.0)THEN
  68. IRT=1
  69. RETURN
  70. ENDIF
  71. ENDIF
  72.  
  73. C Cas tres tres particulier(s)
  74.  
  75. C CAS KOP=1
  76. IF(KOP.EQ.1 )THEN
  77. CALL PRCMCT
  78. C write(6,*) 'Apres KOPS ', LOPER(KOP)
  79. RETURN
  80. ENDIF
  81. C CAS KOP=2
  82. IF(KOP.EQ.2 )THEN
  83. CALL RIMA
  84. C write(6,*) 'Apres KOPS ', LOPER(KOP)
  85. RETURN
  86. ENDIF
  87. IF(KOP.EQ.3)THEN
  88. CALL MACHI2(1)
  89. C write(6,*) 'Apres KOPS ', LOPER(KOP)
  90. RETURN
  91. ENDIF
  92. IF(KOP.EQ.4)THEN
  93. CALL MACHI2(2)
  94. C write(6,*) 'Apres KOPS ', LOPER(KOP)
  95. RETURN
  96. ENDIF
  97. * Mot clé non disponible, voir l'opérateur EXTR 'COMP'
  98. IF(KOP.EQ.5)THEN
  99. CALL EXTIPD
  100. C write(6,*) 'Apres KOPS ', LOPER(KOP)
  101. RETURN
  102. ENDIF
  103. IF(KOP.EQ.6)THEN
  104. CALL EXINCO
  105. C write(6,*) 'Apres KOPS ', LOPER(KOP)
  106. RETURN
  107. ENDIF
  108. IF(KOP.EQ.7)THEN
  109. MTYP=' '
  110. CALL LIROBJ(MTYP,IRET,1,IRETOU)
  111. IF (IERR.NE.0) RETURN
  112. CALL ECRENT(IRET)
  113. C write(6,*) 'Apres KOPS ', LOPER(KOP)
  114. RETURN
  115. ENDIF
  116. IF(KOP.EQ.8)THEN
  117. CALL EXDIAG(1)
  118. C write(6,*) 'Apres KOPS ', LOPER(KOP)
  119. RETURN
  120. ENDIF
  121. IF(KOP.EQ.9)THEN
  122. CALL EXDIAG(2)
  123. C write(6,*) 'Apres KOPS ', LOPER(KOP)
  124. RETURN
  125. ENDIF
  126. IF(KOP.EQ.10)THEN
  127. CALL RELRIG
  128. C write(6,*) 'Apres KOPS ', LOPER(KOP)
  129. RETURN
  130. ENDIF
  131. *
  132. * Condense les relations
  133. *
  134. IF(KOP.EQ.11)THEN
  135. CALL LIROBJ('RIGIDITE',MRIGID,1,IRET)
  136. IF (IERR.NE.0) RETURN
  137. CALL LIROBJ('CHPOINT ',KSMBR,1,IRET)
  138. IF (IERR.NE.0) RETURN
  139. * On ne dédouble pas les multiplicateurs ici
  140. LDMULT=.FALSE.
  141. * On élimine les relations ici, c'est le but
  142. NELIM=1
  143. CALL KRES6(MRIGID,KSMBR,LDMULT,NELIM,
  144. $ MRIGIC,KSMBRC,KSMBR1)
  145. * 2018/10/08 Gérer le cas où il n'y a pas de chpoint ksmbr1 (ksmbr1=0)
  146. if (ksmbr1.eq.0) then
  147. call ecrent(ksmbr1)
  148. else
  149. CALL ECROBJ('CHPOINT ',KSMBR1)
  150. endif
  151. CALL ECROBJ('CHPOINT ',KSMBRC)
  152. CALL ECROBJ('RIGIDITE',MRIGIC)
  153. RETURN
  154. ENDIF
  155. *
  156. * Evapore : opération inverse de la condensation
  157. *
  158. IF(KOP.EQ.12)THEN
  159. CALL LIROBJ('CHPOINT ',MSOLC,1,IRET)
  160. IF (IERR.NE.0) RETURN
  161. CALL LIROBJ('RIGIDITE',MRIGID,1,IRET)
  162. IF (IERR.NE.0) RETURN
  163. CALL LIROBJ('CHPOINT ',KSMBR,1,IRET)
  164. IF (IERR.NE.0) RETURN
  165. CALL LIRENT(KSMBR1,0,IRET)
  166. IF (IRET.EQ.0) THEN
  167. CALL LIROBJ('CHPOINT ',KSMBR1,1,IRET)
  168. ELSE
  169. if (ksmbr1.ne.0) call erreur(5)
  170. ENDIF
  171. IF (IERR.NE.0) RETURN
  172. * Ne pas détruire le champ solution, c'est un objet utilisateur Gibiane
  173. IDTARG=0
  174. CALL KRES7(MSOLC,MRIGID,KSMBR,KSMBR1,IDTARG,
  175. $ MCHSOL)
  176. IF (IERR.NE.0) RETURN
  177. CALL ECROBJ('CHPOINT ',MCHSOL)
  178. RETURN
  179. ENDIF
  180. RETURN
  181. END
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  

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