Télécharger la plaquette Cast3M


fr en

Télécharger fsur.eso

Retour à la liste

Numérotation des lignes : 

fsur

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

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