Télécharger fsur.eso

Retour à la liste

Numérotation des lignes :

  1. C FSUR SOURCE FANDEUR 12/07/18 21:15:43 7434
  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. IF (IERR.NE.0) RETURN
  45. *
  46. * ON LIT SOIT UN CHAMP POINT, SOIT UN VECTEUR
  47. *
  48. CALL LIROBJ('CHPOINT ',IPCHPS,0,iretch)
  49. IF (IERR.NE.0) RETURN
  50. *
  51. * IF (IPCHPS .EQ. 0) THEN
  52. IF (iretch .EQ. 0) THEN
  53. CALL LIROBJ('POINT ',IPVECT,1,iret)
  54. IF (IERR.NE.0) RETURN
  55. ENDIF
  56. *
  57. *-----------------------------------------------------------------------
  58. * ON A LU LE MOT MASSIF
  59. *-----------------------------------------------------------------------
  60. IF (IMLU.EQ.1) THEN
  61. *
  62. * SI ON A LU UN VECTEUR, IL FAUT LIRE UN MAILLAGE OBLIGATOIREMENT
  63. *
  64. IF (IPVECT .NE. 0) THEN
  65. CALL LIROBJ('MAILLAGE',IPMAIL,1,iret)
  66. IF (IERR.NE.0) RETURN
  67. ENDIF
  68. *
  69. * LECTURE D'UN MCHAML DE CARACTERISTIQUES FACULTATIVE
  70. *
  71. CALL LIROBJ('MCHAML',IPCARA,0,iret)
  72. IF (IERR.NE.0) RETURN
  73. *
  74. * CALCUL DU CHAMP POINT DE FORCES NODALES EQUIVALENTES
  75. *
  76. CALL FSURMA(IPMODL,IPCHPS,IPVECT,IPMAIL,IPCARA, IPCHPF)
  77. *
  78. *-----------------------------------------------------------------------
  79. * ON A LU LE MOT COQUE
  80. *-----------------------------------------------------------------------
  81. ELSE IF (IMLU.EQ.2) THEN
  82. *
  83. * LECTURE D'UN MCHAML DE CARACTERISTIQUES FACULTATIVE
  84. *
  85. CALL LIROBJ('MCHAML',IPCARA,0,iret)
  86. IF (IERR.NE.0) RETURN
  87. *
  88. * CALCUL DU CHAMP POINT DE FORCES NODALES EQUIVALENTES
  89. *
  90. CALL FSURCO(IPMODL,IPCHPS,IPVECT,IPCARA, IPCHPF)
  91. *
  92. *-----------------------------------------------------------------------
  93. * ON A LU LE MOT POUT
  94. *-----------------------------------------------------------------------
  95. ELSE IF (IMLU.EQ.3) THEN
  96. *
  97. IVPROJ = 0
  98. *
  99. * LECTURE DU MOT-CLE FACULTATIF 'PROJ'
  100. *
  101. CALL LIRMOT(MTYPR,NTYPR,IPROJ,0)
  102. IF (IERR.NE.0) THEN
  103. CALL ERREUR(7)
  104. RETURN
  105. ENDIF
  106. *
  107. * LECTURE DU VECTEUR SI MOT-CLE 'PROJ' A ETE LU
  108. *
  109. IF (IPROJ.EQ.1) THEN
  110. CALL LIROBJ('POINT ',IVPROJ,1,iret)
  111. IF (IERR.NE.0) RETURN
  112. ENDIF
  113. *
  114. * CALCUL DU CHAMP POINT DE FORCES NODALES EQUIVALENTES
  115. *
  116. CALL FSURPO(IPMODL,IPCHPS,IPVECT,IVPROJ, IPCHPF)
  117. *
  118. ENDIF
  119. *
  120. *-----------------------------------------------------------------------
  121. * FIN DU TRAITEMENT
  122. *-----------------------------------------------------------------------
  123. *
  124. * --> SORTIE PREMATUREE EN CAS D'ERREUR LORS DU CALCUL DES FORCES
  125. *
  126. IF (IERR.NE.0 .OR. IPCHPF.EQ.0) RETURN
  127. *
  128. * --> LE CHAMP DE FORCES NODALES EQUIVALENTES EST DE NATURE DISCRETE
  129. * LE NUMERO DE L HARMONIQUE EST PRIS EGAL A NIFOUR
  130. * POUR TOUTES LES COMPOSANTES DU CHPOINT
  131. *
  132. MCHPOI = IPCHPF
  133. SEGACT,MCHPOI*MOD
  134. NAT = MAX(JATTRI(/1),1)
  135. NSOUPO = IPCHP(/1)
  136. SEGADJ,MCHPOI
  137. JATTRI(1) = 2
  138. DO 10 i = 1, NSOUPO
  139. MSOUPO = IPCHP(i)
  140. SEGACT,MSOUPO*MOD
  141. DO 11 j = 1, NOHARM(/1)
  142. NOHARM(j) = NIFOUR
  143. 11 CONTINUE
  144. SEGDES,MSOUPO
  145. 10 CONTINUE
  146. SEGDES,MCHPOI
  147. *
  148. * --> ECRITURE DU CHPOINT RESULTAT
  149. *
  150. CALL ECROBJ('CHPOINT ',IPCHPF)
  151. *
  152. RETURN
  153. END
  154.  
  155.  
  156.  

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