Télécharger kcha.eso

Retour à la liste

Numérotation des lignes :

  1. C KCHA SOURCE CB215821 19/07/30 21:17:04 10273
  2. SUBROUTINE KCHA
  3. C-----------------------------------------------------------------------
  4. C Transforme un CHPO de support CENTRE en un MCHAML constant par élément
  5. C Transforme un MCHAML constant par élément en un CHPO de support CENTRE
  6. C de nature DIFFUSE
  7. C-----------------------------------------------------------------------
  8. C
  9. C---------------------------
  10. C Phrase d'appel (GIBIANE) :
  11. C---------------------------
  12. C
  13. C RES1 = 'KCHA' MODL1 MOT1 DONN1 ('QUAF')
  14. C TABL1
  15. C
  16. C------------------------
  17. C Opérandes et résultat :
  18. C------------------------
  19. C
  20. C RES1 : Contient le CHPO ou le MCHAML résultat selon l'option MOT1
  21. C Le support de RES1 est soit table.centre, soit table.maillage
  22. C MOT1 : Mot de quatre lettre indiquant le type d'objet à créer
  23. C Si MOT1='CHPO' un MCHAML constant devient un CHPO centre
  24. C Si MOT1='CHAM' un CHPO centre devient un MCHAML constant
  25. C MODL1 : Objet MMODEL
  26. C TABL1 : TABLE Domaine
  27. C DONN1 : Objet à transformer (CHPO OU MCHAML)
  28. C 'QUAF' : mot de 4 lettres indiquant le travail avec maillage QUAF
  29. C plutôt que simple
  30. C
  31. C-----------------------------------------------------------------------
  32. C
  33. C Langage : ESOPE + FORTRAN77
  34. C
  35. C Auteurs : F.DABBENE 07/94
  36. C Révision : 01/99 P.Maugis
  37. C Révision : 11/06 PM : utilisation maillages QUAF
  38. C
  39. C-----------------------------------------------------------------------
  40. IMPLICIT INTEGER(I-N)
  41. IMPLICIT REAL*8 (A-H,O-Z)
  42. PARAMETER (NBOPT=2)
  43. C
  44.  
  45. -INC PPARAM
  46. -INC CCOPTIO
  47. -INC SMCHAML
  48. -INC SMCHPOI
  49. -INC SMELEME
  50. -INC SMTABLE
  51. C
  52. CHARACTER*4 MOTOPT(NBOPT),NOMTOT(1),MOQUAF(1)
  53. DATA MOTOPT / 'CHAM' , 'CHPO' /
  54. DATA MOQUAF / 'QUAF' /
  55. LOGICAL LQUAF
  56. C
  57. C- Lecture de l'option et traitement
  58. C
  59. * on construit un CHAMELEM ou un CHPOINT ?
  60. ICOND = 1
  61. CALL LIRMOT(MOTOPT,NBOPT,IKCHA,ICOND)
  62. IF (IKCHA.EQ.0) RETURN
  63.  
  64. * maillage simple ou QUAF ?
  65. ICOND = 0
  66. CALL LIRMOT(MOQUAF,1,IQUAF,ICOND)
  67. LQUAF = (IQUAF.EQ.1)
  68. C
  69. C Lecture du modèle
  70. C
  71. CALL LIROBJ('MMODEL ',IPMODE,0,IRET)
  72. CALL ACTOBJ('MMODEL ',IPMODE,1)
  73. IF (IERR.NE.0) RETURN
  74. C
  75. C Récupération de la TABLE domaine et des maillages
  76. C
  77. IPTABL = 0
  78. IF(IRET.EQ.0)THEN
  79. CALL LIRTAB('DOMAINE',IPTABL,1,IRET)
  80. IF (IERR.NE.0) RETURN
  81. ELSE
  82. CALL LEKMOD(IPMODE,IPTABL,IRET)
  83. IF (IERR.NE.0) RETURN
  84. ENDIF
  85.  
  86. C Maillage des points centres
  87. CALL LEKTAB(IPTABL,'CENTRE ',IPCENT)
  88. IF (IERR.NE.0) RETURN
  89.  
  90. C- Maillage support voulu
  91. IF (LQUAF) THEN
  92. CALL LEKTAB(IPTABL,'QUAF ',IPGEOM)
  93. IF (IERR.NE.0) RETURN
  94. ELSE
  95. CALL LEKTAB(IPTABL,'MAILLAGE',IPGEOM)
  96. IF (IERR.NE.0) RETURN
  97. ENDIF
  98. C
  99. C- Transformation ...
  100. C
  101. IF (IKCHA.EQ.1) THEN
  102. C
  103. C- d'un CHPO CENTRE en MCHAML constant par élément
  104. C
  105. C Lecture objet à transformer
  106. CALL LIROBJ('CHPOINT ',ICHP1,1,IRET1)
  107. CALL ACTOBJ('CHPOINT ',ICHP1,1)
  108. IF (IERR.NE.0) RETURN
  109. C Construction du segment de travail
  110. NBCOMP = 0
  111. NOMTOT(1) = ' '
  112. CALL KCHA0(ICHP1,IPCENT,NBCOMP,NOMTOT,MTRAV,IREDIR)
  113. C Appel de la procédure de métamorphose :
  114. CALL KCHA1(MTRAV,IPGEOM,IPRESU)
  115. ELSE
  116. C
  117. C- d'un MCHAML constant par élément en CHPO CENTRE
  118. C
  119. C Lecture objet à transformer
  120. CALL LIROBJ('MCHAML ',IPIN,1,IRET1)
  121. CALL ACTOBJ('MCHAML ',IPIN,1)
  122. IF (IERR.NE.0) RETURN
  123. CALL REDUAF(IPIN,IPMODE,IPCHE1,0,IR,KER)
  124. IF(IR .NE. 1) CALL ERREUR(KER)
  125. IF(IERR .NE. 0) RETURN
  126. C Appel de la procédure de métamorphose :
  127. CALL KCHA2(IPCHE1,IPGEOM,IPCENT,IPRESU)
  128. IF(IERR .NE. 0) RETURN
  129. ENDIF
  130. C
  131. C- Ecriture du résultat
  132. C
  133. IF (IPRESU .EQ. 0) then
  134. CALL ERREUR(5)
  135. ELSE
  136. IF (IKCHA .EQ. 1) THEN
  137. CALL ACTOBJ('MCHAML ',IPRESU,1)
  138. CALL ECROBJ('MCHAML ',IPRESU)
  139. ELSE
  140. CALL ACTOBJ('CHPOINT ',IPRESU,1)
  141. CALL ECROBJ('CHPOINT ',IPRESU)
  142. ENDIF
  143. ENDIF
  144.  
  145. END
  146.  
  147.  
  148.  

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