Télécharger calp.eso

Retour à la liste

Numérotation des lignes :

  1. C CALP SOURCE CB215821 16/12/05 21:15:05 9237
  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. * DETECTION DE LA PRESENCE D'UN MCHAML DE DEFORMATION
  58. *
  59. IDEFO=0
  60. MCHELM=IPTS1
  61. SEGACT MCHELM
  62. IF (TITCHE(1:12).EQ.'DEFORMATIONS') THEN
  63. IDEFO=1
  64. ENDIF
  65. SEGDES MCHELM
  66. MCHELM=IPTS2
  67. SEGACT MCHELM
  68. IF (TITCHE(1:12).EQ.'DEFORMATIONS') THEN
  69. IDEFO=1
  70. ENDIF
  71. SEGDES MCHELM
  72.  
  73. *
  74. IF (IDEFO.EQ.1) THEN
  75. CALL RNGCHA(IPTS1,IPTS2,'DEFORMATIONS','CARACTERISTIQUES',
  76. 1 IPTR1,IPTR2)
  77. ELSE
  78. CALL RNGCHA(IPTS1,IPTS2,'CONTRAINTES','CARACTERISTIQUES',
  79. 1 IPTR1,IPTR2)
  80. ENDIF
  81. IF(IERR.NE.0)GOTO 1000
  82. *
  83. * ... CHAMELEM tensoriel ...
  84. *
  85. IF(IPTR1.EQ.0) THEN
  86. MOTERR(1:16)='CONTRAINTES '
  87. CALL ERREUR(291)
  88. RETURN
  89. ENDIF
  90. *
  91. * ... CHAMELEM DE CARACTERISTIQUES ...
  92. *
  93. IF(IPTR2.EQ.0) THEN
  94. MOTERR(1:16)='CARACTERISTIQUES'
  95. CALL ERREUR(291)
  96. RETURN
  97. ENDIF
  98. *
  99. * ... MODELE ...
  100. *
  101. CALL LIROBJ('MMODEL',IPTR3,1,IOK)
  102. IF (IERR.NE.0) GOTO 1000
  103. IPIN=IPTR1
  104. CALL REDUAF(IPIN,IPTR3,IPTR1,0,IR,KER)
  105. IF(IR .NE. 1) CALL ERREUR(KER)
  106. IF(IERR .NE. 0) RETURN
  107.  
  108. IPIN=IPTR2
  109. CALL REDUAF(IPIN,IPTR3,IPTR2,0,IR,KER)
  110. IF(IR .NE. 1) CALL ERREUR(KER)
  111. IF(IERR .NE. 0) RETURN
  112. *
  113. * ... PLAN DE SORTIE DES RESULTATS ...
  114. *
  115. LOC='MOYE'
  116. CALL LIRMOT(LMOT,NBMOT,ILOC,0)
  117. IF (ILOC.NE.0) LOC=LMOT(ILOC)
  118. *
  119. * ... Le calcul lui-même ...
  120. *
  121. IF (IDEFO.EQ.1) THEN
  122. CALL CALP2(IPTR1,IPTR2,IPTR3,LOC,IPTR)
  123. ELSE
  124. CALL CALP1(IPTR1,IPTR2,IPTR3,LOC,IPTR)
  125. ENDIF
  126. *
  127. * ... Sortie du résultat ...
  128. *
  129. IF(IERR.EQ.0) CALL ECROBJ('MCHAML',IPTR)
  130. RETURN
  131. 1000 CONTINUE
  132.  
  133. * projection d un champ de temperature calcule sur un massif
  134. * sur des coques en TINF T et TSUP
  135. *
  136. * Lecture du modele de coque.
  137. *
  138. CALL LIROBJ('MMODEL',IPMODE,1,IRET)
  139. IF (IRET.EQ.0.OR.IERR.NE.0) THEN
  140. RETURN
  141. ENDIF
  142. C on verifie que c est bien un modele de coques
  143.  
  144.  
  145. C identification du champ original de temperature et des
  146. C caracteristiques
  147. IPCHT=itemp
  148. C
  149. if(ipcht.eq.ipts1) then
  150. ipche= ipts2
  151. else
  152. ipche=ipts1
  153. endif
  154.  
  155. call prot(ipmode,ipcht,ipche,iptr)
  156. IF(IERR.EQ.0) CALL ECROBJ('MCHAML',IPTR)
  157. *
  158. return
  159. END
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  

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