C FSCOQ4    SOURCE    OF166741  25/02/21    21:17:02     12166          

      SUBROUTINE FSCOQ4(IPT,IPMAIL,IPTINT,IPVECT,V,IVAFOR)
*____________________________________________________________________
*
*   CALCULE LES FORCES SURFACIQUES SUR LES COQUES COQ4 3D
*
*   ENTREES :
*   ---------
*
*    IPT      TABLEAU DE POINTEURS SUR MPTVAL CONTENANT LES FORCES
*             APPLIQUEES
*    IPMAIL   OBJET GEOMETRIQUE
*    IPTINT   POINTEUR SUR UN MINTE CONTENANT LES POINTS D INTEGRATION
*    IPVECT   POINTEUR SUR LE VECTEUR REPRESENTANT LA FORCE
*    V        VECTEUR REPRESENTANT LA FORCE
*    IVAFOR   POINTEUR SUR UN MPTVAL ET DES MELVALS DEVANT CONTENIR
*             LES FORCES NODALES RESULTANTES
*
*      G. M. GIANNUZZI   SETT  86
*      PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 12 09 90
*
*____________________________________________________________________
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC PPARAM
-INC CCOPTIO

-INC SMCHAML
-INC SMELEME
-INC SMINTE
-INC SMCOORD

-INC TMPTVAL

      DIMENSION IPT(*), V(*)

      DIMENSION XE(3,4),XEL(3,4),BPSS(3,3),SHP(6,4),FTLOC(24),FTGLO(24)

      MELVA1 = IPT(1)
      MELVA2 = IPT(2)
      MELVA3 = IPT(3)
      IF (IPVECT.EQ.0) THEN
        IF (MELVA1.NE.0) THEN
          SEGACT,MELVA1
          IGM1 = MELVA1.VELCHE(/1)
          IBM1 = MELVA1.VELCHE(/2)
        ENDIF
        IF (MELVA2.NE.0) THEN
          SEGACT,MELVA2
          IGM2 = MELVA2.VELCHE(/1)
          IBM2 = MELVA2.VELCHE(/2)
        ENDIF
        IF (MELVA3.NE.0) THEN
          SEGACT,MELVA3
          IGM3 = MELVA3.VELCHE(/1)
          IBM3 = MELVA3.VELCHE(/2)
        ENDIF
        F1 = 0.D0
        F2 = 0.D0
        F3 = 0.D0
      ELSE
        F1 = V(1)
        F2 = V(2)
        F3 = V(3)
      ENDIF
*
      MINTE=IPTINT
C*      SEGACT,MINTE           <- ACTIF EN E/S (NON MODIFIE)
      NBPGAU=POIGAU(/1)
      NBGM1 =NBPGAU-1
*
      MELEME=IPMAIL
C*      SEGACT,MELEME           <- ACTIF EN E/S (NON MODIFIE)
      NBPTEL = NUM(/1)
      NBELEM = NUM(/2)
*
*     BOUCLE SUR LES ELEMENTS
*
      DO 1000 IB=1,NBELEM
*
        CALL DOXE(XCOOR,IDIM,NBPTEL,NUM,IB,XE)
*
*       MATRICE DE PASSAGE  ET COORDONNEES LOCALES
*
        CALL CQ4LOC(XE,XEL,BPSS,IERR,0)
*
*       MISE A 0 DU VECTEUR FORCE
*
        DO I = 1, 24
          FTLOC(I)=0.D0
        ENDDO
*
*        INTEGRATION NUMERIQUE : IGAU NUMERO DU POINT DE GAUSS
*                                IA NUMERO D UN NOEUD
*
        IF (IPVECT.EQ.0) THEN
          IF (MELVA1.NE.0) IBMN1 = MIN(IB,IBM1)
          IF (MELVA2.NE.0) IBMN2 = MIN(IB,IBM2)
          IF (MELVA3.NE.0) IBMN3 = MIN(IB,IBM3)
        ENDIF

        DO 200 IGAU=1,NBGM1
*
          IF (IPVECT.EQ.0) THEN
            IF (MELVA1.NE.0) THEN
              IGMN = MIN(IGAU,IGM1)
              F1 = MELVA1.VELCHE(IGMN,IBMN1)
            ENDIF
            IF (MELVA2.NE.0) THEN
              IGMN = MIN(IGAU,IGM2)
              F2 = MELVA2.VELCHE(IGMN,IBMN2)
            ENDIF
            IF (MELVA3.NE.0) THEN
              IGMN = MIN(IGAU,IGM3)
              F3 = MELVA3.VELCHE(IGMN,IBMN3)
            ENDIF
          ENDIF
*
*   chgt de repere des forces appliquees
*
          F1L = BPSS(1,1)*F1 + BPSS(1,2)*F2 + BPSS(1,3)*F3
          F2L = BPSS(2,1)*F1 + BPSS(2,2)*F2 + BPSS(2,3)*F3
          F3L = BPSS(3,1)*F1 + BPSS(3,2)*F2 + BPSS(3,3)*F3
*
          DO 210 NP = 1, NBPTEL
            SHP(1,NP) = SHPTOT(1,NP,IGAU)
            SHP(2,NP) = SHPTOT(2,NP,IGAU)
            SHP(3,NP) = SHPTOT(3,NP,IGAU)
 210      CONTINUE
          CALL JACOBI(XEL,SHP,2,NBPTEL,DJAC)
          DJAC = DJAC*POIGAU(IGAU)
*
          DJAC1 = DJAC*F1L
          DJAC2 = DJAC*F2L
          DJAC3 = DJAC*F3L
*
          DO 250 NP = 1, NBPTEL
            IC1=(NP-1)*6+1
            IC2=IC1 + 1
            IC3=IC2 + 1
            FTLOC(IC1)=FTLOC(IC1)+SHP(1,NP)*DJAC1
            FTLOC(IC2)=FTLOC(IC2)+SHP(1,NP)*DJAC2
            FTLOC(IC3)=FTLOC(IC3)+SHP(1,NP)*DJAC3
 250      CONTINUE
 200    CONTINUE
*
*     CHANGEMENT DE REPERE
*
        CALL TRPOSE(BPSS)
        CALL MATVEC(FTLOC,FTGLO,BPSS,8)
*
        MPTVAL=IVAFOR
        IE=0
        DO 560 IC=1,4
          DO 560 ID=1,6
            IE=IE+1
            MELVAL=IVAL(ID)
            VELCHE(IC,IB)=FTGLO(IE)
 560    CONTINUE

 1000 CONTINUE

      IF (IPVECT.EQ.0) THEN
        IF (MELVA1.NE.0) SEGDES,MELVA1
        IF (MELVA2.NE.0) SEGDES,MELVA2
        IF (MELVA3.NE.0) SEGDES,MELVA3
      ENDIF
C*      SEGDES,MINTE
C*      SEGDES,MELEME

      RETURN
      END