Télécharger calp.eso

Retour à la liste

Numérotation des lignes :

calp
  1. C CALP SOURCE CB215821 19/08/01 21:15:07 10279
  2. SUBROUTINE CALP
  3. *
  4. *
  5. * AUTEUR : J.BRUN (AVRIL 90)
  6. *
  7. *-----------------------------------------------------------
  8. * BUT :
  9. * ENTETE DE L'OPERATEUR SERVANT A CALCULER LES CONTRAINTES
  10. * OU LES DEFORMATIONS EN PEAU OU AU PLAN MOYEN
  11. *
  12. *
  13. *----------------------------------------------------------
  14. IMPLICIT INTEGER(I-N)
  15. IMPLICIT REAL*8 (A-H,O-Z)
  16. *
  17. -INC SMCHAML
  18.  
  19. -INC PPARAM
  20. -INC CCOPTIO
  21. *
  22. CHARACTER*4 LMOT(3),LOC
  23. DATA LMOT/'INFE','MOYE','SUPE'/
  24. NBMOT=3
  25. *----------------------------------------------------------
  26. *
  27. * LECTURE DES PARAMETRES EN ENTREE
  28. *
  29. *----------------------------------------------------------
  30. *
  31. * LECTURE DE 2 CHAMELEMS QUELCONQUES
  32. *
  33. CALL LIROBJ('MCHAML ',IPTS1,1,IOK)
  34. CALL ACTOBJ('MCHAML ',IPTS1,1)
  35. IF (IERR.NE.0) RETURN
  36. CALL LIROBJ('MCHAML ',IPTS2,1,IOK)
  37. CALL ACTOBJ('MCHAML ',IPTS2,1)
  38. IF (IERR.NE.0) RETURN
  39. *
  40. * DETECTION DE LA PRESENCE D'UN MCHAML SCALAIRE (T)
  41. * pour option T ---> TINF T TSUP
  42. ITEMP=0
  43. MCHELM=IPTS1
  44. SEGACT MCHELM
  45. IF (TITCHE(1:12).EQ.'SCALAIRE ') THEN
  46. ITEMP=IPTS1
  47. SEGDES MCHELM
  48. GOTO 1000
  49. ENDIF
  50. SEGDES MCHELM
  51. MCHELM=IPTS2
  52. SEGACT MCHELM
  53. IF (TITCHE(1:12).EQ.'SCALAIRE ') THEN
  54. ITEMP=IPTS2
  55. SEGDES MCHELM
  56. GOTO 1000
  57. ENDIF
  58. SEGDES MCHELM
  59.  
  60. *----------------------------------------------------------------------
  61. * 1ere FONCTION
  62. *----------------------------------------------------------------------
  63.  
  64. *
  65. * DETECTION DE LA PRESENCE D'UN MCHAML DE DEFORMATION
  66. *
  67. IDEFO=0
  68. MCHELM=IPTS1
  69. SEGACT MCHELM
  70. IF (TITCHE(1:12).EQ.'DEFORMATIONS') THEN
  71. IDEFO=1
  72. ENDIF
  73. SEGDES MCHELM
  74. MCHELM=IPTS2
  75. SEGACT MCHELM
  76. IF (TITCHE(1:12).EQ.'DEFORMATIONS') THEN
  77. IDEFO=1
  78. ENDIF
  79. SEGDES MCHELM
  80.  
  81. *
  82. IF (IDEFO.EQ.1) THEN
  83. CALL RNGCHA(IPTS1,IPTS2,'DEFORMATIONS','CARACTERISTIQUES',
  84. 1 IPTR1,IPTR2)
  85. ELSE
  86. CALL RNGCHA(IPTS1,IPTS2,'CONTRAINTES','CARACTERISTIQUES',
  87. 1 IPTR1,IPTR2)
  88. ENDIF
  89. IF(IERR.NE.0) RETURN
  90. *
  91. * ... CHAMELEM tensoriel ...
  92. *
  93. IF(IPTR1.EQ.0) THEN
  94. MOTERR(1:16)='CONTRAINTES '
  95. CALL ERREUR(291)
  96. RETURN
  97. ENDIF
  98. *
  99. * ... CHAMELEM DE CARACTERISTIQUES ...
  100. *
  101. IF(IPTR2.EQ.0) THEN
  102. MOTERR(1:16)='CARACTERISTIQUES'
  103. CALL ERREUR(291)
  104. RETURN
  105. ENDIF
  106. *
  107. * ... MODELE ...
  108. *
  109. CALL LIROBJ('MMODEL ',IPTR3,1,IOK)
  110. CALL ACTOBJ('MMODEL ',IPTR3,1)
  111. IF (IERR.NE.0) RETURN
  112. CALL ACTOBJ('MMODEL ',IPTR3,1)
  113.  
  114. IPIN=IPTR1
  115. CALL ACTOBJ('MCHAML ',IPIN,1)
  116. CALL REDUAF(IPIN,IPTR3,IPTR1,0,IR,KER)
  117. IF(IR .NE. 1) CALL ERREUR(KER)
  118. IF(IERR .NE. 0) RETURN
  119.  
  120. IPIN=IPTR2
  121. CALL ACTOBJ('MCHAML ',IPIN,1)
  122. CALL REDUAF(IPIN,IPTR3,IPTR2,0,IR,KER)
  123. IF(IR .NE. 1) CALL ERREUR(KER)
  124. IF(IERR .NE. 0) RETURN
  125. *
  126. * ... PLAN DE SORTIE DES RESULTATS ...
  127. *
  128. LOC='MOYE'
  129. CALL LIRMOT(LMOT,NBMOT,ILOC,0)
  130. IF (ILOC.NE.0) LOC=LMOT(ILOC)
  131. *
  132. * ... Le calcul lui-même ...
  133. *
  134. IF (IDEFO.EQ.1) THEN
  135. CALL CALP2(IPTR1,IPTR2,IPTR3,LOC,IPTR)
  136. ELSE
  137. CALL CALP1(IPTR1,IPTR2,IPTR3,LOC,IPTR)
  138. ENDIF
  139. *
  140. * ... Sortie du résultat ...
  141. *
  142. IF(IERR.EQ.0) THEN
  143. CALL ACTOBJ('MCHAML ',IPTR,1)
  144. CALL ECROBJ('MCHAML ',IPTR)
  145. ENDIF
  146. C
  147. RETURN
  148.  
  149. *----------------------------------------------------------------------
  150. * 2nd FONCTION
  151. *----------------------------------------------------------------------
  152.  
  153. 1000 CONTINUE
  154.  
  155. * projection d un champ de temperature calcule sur un massif
  156. * sur des coques en TINF T et TSUP
  157. *
  158. * Lecture du modele de coque.
  159. *
  160. CALL LIROBJ('MMODEL ',IPMODE,1,IRET)
  161. CALL ACTOBJ('MMODEL ',IPMODE,1)
  162. IF (IERR.NE.0) RETURN
  163.  
  164. C on verifie que c est bien un modele de coques
  165. C identification du champ original de temperature et des
  166. C caracteristiques
  167. IPCHT=itemp
  168. C
  169. if(ipcht.eq.ipts1) then
  170. ipche= ipts2
  171. else
  172. ipche=ipts1
  173. endif
  174.  
  175. call prot(ipmode,ipcht,ipche,iptr)
  176. IF(IERR.EQ.0) THEN
  177. CALL ACTOBJ('MCHAML ',IPTR,1)
  178. CALL ECROBJ('MCHAML ',IPTR)
  179. ENDIF
  180. *
  181. return
  182. END
  183.  
  184.  
  185.  
  186.  

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