C FSUR      SOURCE    CB215821  23/07/12    21:15:05     11704          
*
      SUBROUTINE FSUR
*
*-----------------------------------------------------------------------
*
*                     OPERATEUR FSUR
*
*-----------------------------------------------------------------------
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
*

-INC SMCOORD
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
*
      PARAMETER (NTYPE = 3, NTYPR = 1)
      CHARACTER*4 MTYPE(NTYPE),MTYPR(NTYPR)
*
      DATA MTYPE / 'MASS','COQU','POUT' /
      DATA MTYPR / 'PROJ' /
*
      IMLU   = 0
      IPMODL = 0
      IPCHPS = 0
      IPVECT = 0
      IPMAIL = 0
      IPCARA = 0
      IPCHPF = 0
*
*-----------------------------------------------------------------------
*     LECTURE DES ARGUMENTS
*-----------------------------------------------------------------------
*
*  ON LIT UN MOT-CLE OBLIGATOIRE
*
      CALL LIRMOT(MTYPE,NTYPE,IMLU,1)
      IF (IERR.NE.0) RETURN
*
*  ON LIT UN MMODEL OBLIGATOIRE
*
      CALL LIROBJ('MMODEL  ',IPMODL,1,iret)
      CALL ACTOBJ('MMODEL  ',IPMODL,1)
      IF (IERR.NE.0) RETURN
*
*  ON LIT SOIT UN CHAMP POINT, SOIT UN VECTEUR
*
      CALL LIROBJ('CHPOINT ',IPCHPS,0,iretch)
      IF(iretch .EQ. 1) CALL ACTOBJ('CHPOINT ',IPCHPS,1)
      IF (IERR.NE.0) RETURN
*
*     IF (IPCHPS .EQ. 0) THEN
      IF (iretch .EQ. 0) THEN
        CALL LIROBJ('POINT   ',IPVECT,1,iret)
        IF (IERR.NE.0) RETURN
      ENDIF
*
*-----------------------------------------------------------------------
*        ON A LU LE MOT   MASSIF
*-----------------------------------------------------------------------
      SEGACT,MCOORD
      IF (IMLU.EQ.1) THEN
*
*       SI ON A LU UN VECTEUR, IL FAUT LIRE UN MAILLAGE OBLIGATOIREMENT
*
        IF (IPVECT .NE. 0) THEN
          CALL LIROBJ('MAILLAGE',IPMAIL,1,iret)
          CALL ACTOBJ('MAILLAGE',IPMAIL,1)
          IF (IERR.NE.0) RETURN
        ENDIF
*
*       LECTURE D'UN MCHAML DE CARACTERISTIQUES FACULTATIVE
*
        CALL LIROBJ('MCHAML  ',IPCARA,0,iret)
        IF(iret .EQ. 1) CALL ACTOBJ('MCHAML  ',IPCARA,1)
        IF (IERR.NE.0) RETURN
*
*       CALCUL DU CHAMP POINT DE FORCES NODALES EQUIVALENTES
*
        CALL FSURMA(IPMODL,IPCHPS,IPVECT,IPMAIL,IPCARA, IPCHPF)
*
*-----------------------------------------------------------------------
*        ON A LU LE MOT   COQUE
*-----------------------------------------------------------------------
      ELSE IF (IMLU.EQ.2) THEN
*
*       LECTURE D'UN MCHAML DE CARACTERISTIQUES FACULTATIVE
*
        CALL LIROBJ('MCHAML',IPCARA,0,iret)
        IF(iret .EQ. 1) CALL ACTOBJ('MCHAML  ',IPCARA,1)
        IF (IERR.NE.0) RETURN
*
*       CALCUL DU CHAMP POINT DE FORCES NODALES EQUIVALENTES
*
        CALL FSURCO(IPMODL,IPCHPS,IPVECT,IPCARA, IPCHPF)
*
*-----------------------------------------------------------------------
*        ON A LU LE MOT   POUT
*-----------------------------------------------------------------------
      ELSE IF (IMLU.EQ.3) THEN
*
        IVPROJ = 0
*
*       LECTURE DU MOT-CLE FACULTATIF 'PROJ'
*
        CALL LIRMOT(MTYPR,NTYPR,IPROJ,0)
        IF (IERR.NE.0) RETURN
*
*       LECTURE DU VECTEUR SI MOT-CLE 'PROJ' A ETE LU
*
        IF (IPROJ.EQ.1) THEN
          CALL LIROBJ('POINT   ',IVPROJ,1,iret)
          IF (IERR.NE.0) RETURN
        ENDIF
*
*       CALCUL DU CHAMP POINT DE FORCES NODALES EQUIVALENTES
*
        CALL FSURPO(IPMODL,IPCHPS,IPVECT,IVPROJ, IPCHPF)
*
      ENDIF
      SEGDES,MCOORD
*
*-----------------------------------------------------------------------
*     FIN DU TRAITEMENT
*-----------------------------------------------------------------------
*
* --> SORTIE PREMATUREE EN CAS D'ERREUR LORS DU CALCUL DES FORCES
*
      IF (IERR.NE.0 .OR. IPCHPF.EQ.0) RETURN
*
* --> LE CHAMP DE FORCES NODALES EQUIVALENTES EST DE NATURE DISCRETE
*     LE NUMERO DE L HARMONIQUE EST PRIS EGAL A NIFOUR
*     POUR TOUTES LES COMPOSANTES DU CHPOINT
*
      MCHPOI = IPCHPF
      SEGACT,MCHPOI*MOD
      NAT = MAX(JATTRI(/1),1)
      NSOUPO = IPCHP(/1)
      SEGADJ,MCHPOI
      JATTRI(1) = 2
      DO 10 i = 1, NSOUPO
        MSOUPO = IPCHP(i)
        SEGACT,MSOUPO*MOD
        DO 11 j = 1, NOHARM(/1)
          NOHARM(j) = NIFOUR
 11     CONTINUE
 10   CONTINUE
*
* --> ECRITURE DU CHPOINT RESULTAT
*
      CALL ACTOBJ('CHPOINT ',IPCHPF,1)
      CALL ECROBJ('CHPOINT ',IPCHPF)

      END