Télécharger calp.eso

Retour à la liste

Numérotation des lignes :

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

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