Télécharger fsur.eso

Retour à la liste

Numérotation des lignes :

  1. C FSUR SOURCE CB215821 19/07/30 21:16:35 10273
  2. *
  3. SUBROUTINE FSUR
  4. *
  5. *-----------------------------------------------------------------------
  6. *
  7. * OPERATEUR FSUR
  8. *
  9. *-----------------------------------------------------------------------
  10. *
  11. IMPLICIT INTEGER(I-N)
  12. IMPLICIT REAL*8 (A-H,O-Z)
  13. *
  14. -INC CCOPTIO
  15. *
  16. -INC SMCHPOI
  17. *
  18. PARAMETER (NTYPE = 3, NTYPR = 1)
  19. CHARACTER*4 MTYPE(NTYPE),MTYPR(NTYPR)
  20. *
  21. DATA MTYPE / 'MASS','COQU','POUT' /
  22. DATA MTYPR / 'PROJ' /
  23. *
  24. IMLU = 0
  25. IPMODL = 0
  26. IPCHPS = 0
  27. IPVECT = 0
  28. IPMAIL = 0
  29. IPCARA = 0
  30. IPCHPF = 0
  31. *
  32. *-----------------------------------------------------------------------
  33. * LECTURE DES ARGUMENTS
  34. *-----------------------------------------------------------------------
  35. *
  36. * ON LIT UN MOT-CLE OBLIGATOIRE
  37. *
  38. CALL LIRMOT(MTYPE,NTYPE,IMLU,1)
  39. IF (IERR.NE.0) RETURN
  40. *
  41. * ON LIT UN MMODEL OBLIGATOIRE
  42. *
  43. CALL LIROBJ('MMODEL ',IPMODL,1,iret)
  44. CALL ACTOBJ('MMODEL ',IPMODL,1)
  45. IF (IERR.NE.0) RETURN
  46. *
  47. * ON LIT SOIT UN CHAMP POINT, SOIT UN VECTEUR
  48. *
  49. CALL LIROBJ('CHPOINT ',IPCHPS,0,iretch)
  50. IF(iretch .EQ. 1) CALL ACTOBJ('CHPOINT ',IPCHPS,1)
  51. IF (IERR.NE.0) RETURN
  52. *
  53. * IF (IPCHPS .EQ. 0) THEN
  54. IF (iretch .EQ. 0) THEN
  55. CALL LIROBJ('POINT ',IPVECT,1,iret)
  56. IF (IERR.NE.0) RETURN
  57. ENDIF
  58. *
  59. *-----------------------------------------------------------------------
  60. * ON A LU LE MOT MASSIF
  61. *-----------------------------------------------------------------------
  62. IF (IMLU.EQ.1) THEN
  63. *
  64. * SI ON A LU UN VECTEUR, IL FAUT LIRE UN MAILLAGE OBLIGATOIREMENT
  65. *
  66. IF (IPVECT .NE. 0) THEN
  67. CALL ACTOBJ('MAILLAGE',IPMAIL,1)
  68. CALL LIROBJ('MAILLAGE',IPMAIL,1,iret)
  69. IF (IERR.NE.0) RETURN
  70. ENDIF
  71. *
  72. * LECTURE D'UN MCHAML DE CARACTERISTIQUES FACULTATIVE
  73. *
  74. CALL LIROBJ('MCHAML ',IPCARA,0,iret)
  75. IF(iret .EQ. 1) CALL ACTOBJ('MCHAML ',IPCARA,1)
  76. IF (IERR.NE.0) RETURN
  77. *
  78. * CALCUL DU CHAMP POINT DE FORCES NODALES EQUIVALENTES
  79. *
  80. CALL FSURMA(IPMODL,IPCHPS,IPVECT,IPMAIL,IPCARA, IPCHPF)
  81. *
  82. *-----------------------------------------------------------------------
  83. * ON A LU LE MOT COQUE
  84. *-----------------------------------------------------------------------
  85. ELSE IF (IMLU.EQ.2) THEN
  86. *
  87. * LECTURE D'UN MCHAML DE CARACTERISTIQUES FACULTATIVE
  88. *
  89. CALL LIROBJ('MCHAML',IPCARA,0,iret)
  90. IF(iret .EQ. 1) CALL ACTOBJ('MCHAML ',IPCARA,1)
  91. IF (IERR.NE.0) RETURN
  92. *
  93. * CALCUL DU CHAMP POINT DE FORCES NODALES EQUIVALENTES
  94. *
  95. CALL FSURCO(IPMODL,IPCHPS,IPVECT,IPCARA, IPCHPF)
  96. *
  97. *-----------------------------------------------------------------------
  98. * ON A LU LE MOT POUT
  99. *-----------------------------------------------------------------------
  100. ELSE IF (IMLU.EQ.3) THEN
  101. *
  102. IVPROJ = 0
  103. *
  104. * LECTURE DU MOT-CLE FACULTATIF 'PROJ'
  105. *
  106. CALL LIRMOT(MTYPR,NTYPR,IPROJ,0)
  107. IF (IERR.NE.0) THEN
  108. CALL ERREUR(7)
  109. RETURN
  110. ENDIF
  111. *
  112. * LECTURE DU VECTEUR SI MOT-CLE 'PROJ' A ETE LU
  113. *
  114. IF (IPROJ.EQ.1) THEN
  115. CALL LIROBJ('POINT ',IVPROJ,1,iret)
  116. IF (IERR.NE.0) RETURN
  117. ENDIF
  118. *
  119. * CALCUL DU CHAMP POINT DE FORCES NODALES EQUIVALENTES
  120. *
  121. CALL FSURPO(IPMODL,IPCHPS,IPVECT,IVPROJ, IPCHPF)
  122. *
  123. ENDIF
  124. *
  125. *-----------------------------------------------------------------------
  126. * FIN DU TRAITEMENT
  127. *-----------------------------------------------------------------------
  128. *
  129. * --> SORTIE PREMATUREE EN CAS D'ERREUR LORS DU CALCUL DES FORCES
  130. *
  131. IF (IERR.NE.0 .OR. IPCHPF.EQ.0) RETURN
  132. *
  133. * --> LE CHAMP DE FORCES NODALES EQUIVALENTES EST DE NATURE DISCRETE
  134. * LE NUMERO DE L HARMONIQUE EST PRIS EGAL A NIFOUR
  135. * POUR TOUTES LES COMPOSANTES DU CHPOINT
  136. *
  137. MCHPOI = IPCHPF
  138. SEGACT,MCHPOI*MOD
  139. NAT = MAX(JATTRI(/1),1)
  140. NSOUPO = IPCHP(/1)
  141. SEGADJ,MCHPOI
  142. JATTRI(1) = 2
  143. DO 10 i = 1, NSOUPO
  144. MSOUPO = IPCHP(i)
  145. SEGACT,MSOUPO*MOD
  146. DO 11 j = 1, NOHARM(/1)
  147. NOHARM(j) = NIFOUR
  148. 11 CONTINUE
  149. 10 CONTINUE
  150. *
  151. * --> ECRITURE DU CHPOINT RESULTAT
  152. *
  153. CALL ACTOBJ('CHPOINT ',IPCHPF,1)
  154. CALL ECROBJ('CHPOINT ',IPCHPF)
  155.  
  156. END
  157.  
  158.  
  159.  

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