Sources Esope | Cast3M

tailpo
C TAILPO    SOURCE    CB215821  24/04/12    21:17:18     11897          
C           responsable : Mr MILLARD
C=======================================================================
C
      SUBROUTINE TAILPO(IPMODL,IPCHE,IUNIF,IRET)
C
C=======================================================================
C    ENTREES :
C    ---------
C      IPMODL= pointeur sur un MMODEL
C
C    SORTIES :
C    --------
C      IPCHE = CHAMELEM contenant les parametres de tailles aux
C      point de GAUSS necessaire a modele beton OTTOSEN
C      IRET  = 1 si succes 0 sinon
C=======================================================================
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
      PARAMETER(XUN=1.D0,XZER=0.D0)
      EXTERNAL SHAPE
 
 
-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC SMCHAML
-INC SMMODEL
-INC SMELEME
-INC SMCOORD
-INC SMINTE
 
      SEGMENT MTRA1
       REAL*8 XEL(3,NBNN)
       REAL*8 VCOMP(NCOMP)
       REAL*8 SHP(6,NBNN),SHPZER(6,NBNN)
       REAL*8 SHPQSI(6,NBNN),SHPETA(6,NBNN),SHPDZE(6,NBNN)
C*     REAL*8 SHPGAU(6,NBNN)
      ENDSEGMENT
 
      SEGMENT MTRA2
        REAL*8 BPSS(3,3),YEL(3,NBNN)
      ENDSEGMENT
 
*      SEGMENT INFO
*       INTEGER INFELE(JG)
*      ENDSEGMENT
C
C     ACTIVATION DU MODELE
C
      MMODEL= IPMODL
      NSOUS=KMODEL(/1)
C
C     CREATION DU MCHELM
C
      N1=NSOUS
      L1=16
      N3=6
      SEGINI,MCHELM
      TITCHE='CARACTERISTIQUES'
      IFOCHE=IFOUR
      NHRM=NIFOUR
 
C=======================================================================
C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
C=======================================================================
C
      DO 500 ISOUS=1,NSOUS
C
C-----------------------------------------------------------------------
C     Traitement du modele de la sous-zone ISOUS
C-----------------------------------------------------------------------
        IMODEL=KMODEL(ISOUS)
        IPMAIL=IMAMOD
C Numero de l element fini dans nomtp de CCHAMP.INC
        MELE=NEFMOD
        NFOR=FORMOD(/2)
 
C       Recherche de formulations particulieres
        CALL PLACE(FORMOD,NFOR,ITHER ,'THERMIQUE'     )
        CALL PLACE(FORMOD,NFOR,IDIFF ,'DIFFUSION'     )
        CALL PLACE(FORMOD,NFOR,ITHEHY,'THERMOHYDRIQUE')
 
C-----------------------------------------------------------------------
C     INFORMATION SUR L'ELEMENT FINI
C-----------------------------------------------------------------------
*        CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
*        IF (IERR.NE.0) THEN
*          CALL ERREUR(660)
*          RETURN
*        ENDIF
*        INFO=IPINF
 
        IF (ITHER.NE.0 .OR. IDIFF.NE.0 .OR. ITHEHY.NE.0) THEN
          MFR=NUMMFR(MELE)
          CALL TSHAPE(MELE,'GAUSS',MINTE)
          MFR=NUMMFR(MELE)
 
        ELSE
          MELE=INFELE(1)
C         Numero de la formulation de l element fini (massif ...)
          MFR =INFELE(13)
C         Pointeur sur un segment d integration
          MINTE=INFMOD(5)
        ENDIF
        IELE=NUMGEO(MELE)
 
*        MINTE=INFELE(11)
*        SEGSUP INFO
C-----------------------------------------------------------------------
C- CREATION DU MCHAML DE LA SOUS ZONE---------------------
C-----------------------------------------------------------------------
C Remplissage de l'entete dans le MCHELM
C     pointeur sur le maillage de la sous zone (maillage elementaire)
        IMACHE(ISOUS)=IPMAIL
C     Nom du constituant
        CONCHE(ISOUS)=CONMOD
C     =0 pour des valeurs independantes du repere
C     en fait, ces valeurs dependent du repere global mais
C     nous voulons un champ de caracteristiques (donc idpt du repere)
        INFCHE(ISOUS,1)=0
        INFCHE(ISOUS,2)=0
C     numero de l harmonique de Fourier
        INFCHE(ISOUS,3)=NHRM
C     pointeur sur un SMINTE
        INFCHE(ISOUS,4)=MINTE
C     =0 pour des champs de defomations et contraintes usuels
        INFCHE(ISOUS,5)=0
C     =3 SMINTE pointe sur un segment d integration aux pts de GAUSS
C     pour la rigidite
        IF (ITHER.NE.0 .OR. IDIFF.NE.0 .OR. ITHEHY.NE.0) THEN
          INFCHE(ISOUS,6)=6
 
        ELSE
          INFCHE(ISOUS,6)=3
        ENDIF
C NOMBRE DES COMPOSANTES SELON LA DIMENSION
        N2 = 0
        IF (IDIM.EQ.2) N2=7
        IF (IDIM.EQ.3.AND.(MFR.EQ.3.OR.MFR.EQ.9 )) N2=7
        IF (IDIM.EQ.3.AND.(MFR.EQ.1.OR.MFR.EQ.31)) N2=12
C ERREUR FORMULATION INDISPONIBLE
        IF (N2 .EQ. 0) THEN
          MOTERR(1:8)=NOMFR(MFR)
          CALL ERREUR(193)
          RETURN
        ENDIF
C-----------------------------------------------------------------------
C CREATION DU MCHAML
C-----------------------------------------------------------------------
        SEGINI MCHAML
        ICHAML(ISOUS)=MCHAML
C-----------------------------------------------------------------------
C Remplissage du MCHAML
C-----------------------------------------------------------------------
        NCOMP = N2
        DO i=1,NCOMP
          TYPCHE(i)='REAL*8'
        ENDDO
*
C NOM DES COMPOSANTES SELON LA DIMENSION
C     Si l option de calcul est PLAN
        IF (IFOMOD.EQ.-1) THEN
          NOMCHE(1)='LXX '
          NOMCHE(2)='LYY '
          NOMCHE(3)='LZZ '
          NOMCHE(4)='LXY '
          NOMCHE(5)='PXX '
          NOMCHE(6)='PYY '
          NOMCHE(7)='PXY '
C     Si l option de calcul est AXIS ou FOUR
        ELSE IF (IFOMOD.EQ.0.OR.IFOMOD.EQ.1) THEN
          NOMCHE(1)='LRR '
          NOMCHE(2)='LZZ '
          NOMCHE(3)='LOO '
          NOMCHE(4)='LRZ '
          NOMCHE(5)='PRR '
          NOMCHE(6)='PZZ '
          NOMCHE(7)='PRZ '
C     Si l option de calcul est TRID  CAS MASSIF
        ELSE IF (IFOMOD.EQ.2.AND.(MFR.EQ.1.OR.MFR.EQ.31)) THEN
          NOMCHE( 1)='LXX '
          NOMCHE( 2)='LYY '
          NOMCHE( 3)='LZZ '
          NOMCHE( 4)='LXY '
          NOMCHE( 5)='LXZ '
          NOMCHE( 6)='LYZ '
          NOMCHE( 7)='PXX '
          NOMCHE( 8)='PYY '
          NOMCHE( 9)='PZZ '
          NOMCHE(10)='PXY '
          NOMCHE(11)='PXZ '
          NOMCHE(12)='PYZ '
C     Si l option de calcul est TRID  CAS COQUES
        ELSE IF (IFOMOD.EQ.2.AND.(MFR.EQ.3.OR.MFR.EQ.9)) THEN
          NOMCHE(1)='LSS '
          NOMCHE(2)='LTT '
          NOMCHE(3)='LNN '
          NOMCHE(4)='LST '
          NOMCHE(5)='PSS '
          NOMCHE(6)='PTT '
          NOMCHE(7)='PST '
        ELSE
          CALL ERREUR(5)
        ENDIF
C
C-----------------------------------------------------------------------
C CREATION ET REMPLISSAGE DU MELVAL DE CHAQUE COMPOSANTE
C-----------------------------------------------------------------------
C Nous n avons que des composantes scalaires donc N2*=0----
        N2PTEL=0
        N2EL  =0
C Cas 1 : Champs UNIFORMEs (valeur nulle)
        IF (IUNIF.NE.0) THEN
          N1PTEL=1
          N1EL=1
          DO i=1,NCOMP
            SEGINI,MELVAL
            IELVAL(i)=MELVAL
            VELCHE(1,1)=XZER
          ENDDO
C Cas 2 : Calculs des tenseurs en chaque point d'integration !
        ELSE
C---------INFORMATION sur les fonctions de forme ( MINTE )---------
          NBPGAU=POIGAU(/1)
C----ACTIVATION DU MELEME : Maillage elementaire de la sous zone---
          MELEME=IPMAIL
          NBNN  =NUM(/1)
          NBELEM=NUM(/2)
          N1PTEL=NBPGAU
          N1EL  =NBELEM
C-Initialisation du segment des valeurs aux points de Gauss
          DO i=1,NCOMP
            SEGINI,MELVAL
            IELVAL(i)=MELVAL
          ENDDO
C-- Segments de travail
          SEGINI,MTRA1
          MTRA2=0
          IF (IDIM.EQ.3.AND.(MFR.EQ.3.OR.MFR.EQ.9)) SEGINI,MTRA2
C--------------------------------------------------------------------
C          initialisation des fonctions de formes aux points de GAUSS
C              pour l element de reference de cette sous zone
C--------------------------------------------------------------------
C-initialisation des fonctions de forme a l origine et sur les axes-
          CALL SHAPE(XZER,XZER,XZER,IELE,SHPZER,IRET)
*         IF (IRET.EQ.0) THEN
*           CALL ERREUR(662)
*           GOTO 592
*         ENDIF
          CALL SHAPE(XUN,XZER,XZER,IELE,SHPQSI,IRET)
*          IF (IRET.EQ.0) THEN
*            CALL ERREUR(662)
*            GOTO 592
*          ENDIF
          CALL SHAPE(XZER,XUN,XZER,IELE,SHPETA,IRET)
*          IF (IRET.EQ.0) THEN
*            CALL ERREUR(662)
*            GOTO 592
*          ENDIF
          CALL SHAPE(XZER,XZER,XUN,IELE,SHPDZE,IRET)
          IF (IRET.EQ.0) THEN
            CALL ERREUR(662)
            GOTO 592
          ENDIF
 
C                BOUCLE SUR CHAQUE ELEMENT
C-----------------------------------------------------------------------
          DO 1000 IB=1,NBELEM
C           extraction des coordonnees des noeuds de l element IB
C                     resultat dans XEL
            CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
C
C   CAS DES COQUES 3D - RECHERCHE DES COORDONNEES LOCALES
            IF (IDIM.EQ.3.AND.(MFR.EQ.3.OR.MFR.EQ.9)) THEN
C*          IF (MTRA2.NE.0) THEN
              DO j=1,NBNN
                DO i=1,3
                  YEL(i,j)=XEL(i,j)
                ENDDO
              ENDDO
              CALL VPAST(YEL,BPSS)
              CALL VCORL1(YEL,XEL,BPSS,NBNN)
            ENDIF
C
C          BOUCLE SUR CHAQUE POINT DE GAUSS
C=============================================================
            DO 1004 IC=1,NBPGAU
              DO j=1,NBNN
                DO i=1,6
                  SHP(i,j)=SHPTOT(i,j,IC)
                ENDDO
              ENDDO
              POI=POIGAU(IC)
*              QSI=QSIGAU(IC)
*              ETA=ETAGAU(IC)
*              DZE=DZEGAU(IC)
*              CALL SHAPE(QSI,ETA,DZE,IELE,SHPGAU,IRET)
*              IF (IRET.EQ.0) THEN
*                CALL ERREUR(662)
*                GOTO 592
*             ENDIF
C
              CALL TAILCA(MTRA1,POI,IDIM,IFOUR,NBNN,MELE,IELE,MFR,IRET)
              IF (IRET.EQ.0) THEN
                CALL ERREUR(663)
                GOTO 592
              ENDIF
C
              DO i=1,NCOMP
                MELVAL=IELVAL(i)
                VELCHE(IC,IB)=VCOMP(i)
              ENDDO
C
 1004       CONTINUE
C
 1000     CONTINUE
 
 592      CONTINUE
          SEGSUP,MTRA1
          IF (MTRA2.NE.0) SEGSUP,MTRA2
        ENDIF
 
        IF (IERR.NE.0) GOTO 9990
C============================================================
C------------ BOUCLE SUR LES SOUS ZONES RESTANTES -----------
C============================================================
 500  CONTINUE
 
C---------------------FIN NORMAL DU CALCUL-------------------------
      IPCHE=MCHELM
      IRET=1
      RETURN
 
C-------------------------------------------------------------------
C         ERREUR DANS UNE ZONE , DESACTIVATION ET RETOUR
C-------------------------------------------------------------------
 9990 CONTINUE
      SEGSUP,MCHELM
      IPCHE=0
      IRET =0
 
      END