Sources Esope | Cast3M

quahr1
C QUAHR1    SOURCE    CHAT      05/01/13    02:41:02     5004
C QUAHR1    SOURCE    AM1       95/11/24    22:55:49     1918
      SUBROUTINE QUAHR1(IGAU,ITEL,MFR,NBNO,IFOU,NIFOU,XEL,
     #                  SHPTOT,SHP,NST,ISDJC,XGENE,DJAC,IRET)
C=======================================================================
C
C    CALCULE LA MATRICE XGENE (NECESSAIRE POUR LE CALCUL  DE LA MATRICE
C       DE RIGIDITE DANS LE CAS DE LA FORMULATION (37) HOMOGENE    )
C          ROUTINE FORTRAN PUR
C=======================================================================
C  INPUT
C     IGAU=NUMERO DU POINT DE GAUSS
C     ITEL=NUMERO DE L ELEMENT DANS NOMTP
C     MFR =NUMERO DE LA FORMULATION
C     NBNO=NOMBRE DE NOEUDS
C     LRE =NOMBRE DE COLONNES DE LA MATRICE B
C     IFOU=IFOUR DE CCOPTIO
C     NIFOU=NIFOUR DE CCOPTIO
C     XEL =COORDONNEES  DE L ELEMENT
C     SHPTOT(6,NBNO,NBGAU)=FONCTIONS DE FORMES ET DERIVEES
C     ISDJC = INDICATEUR SUR LE SIGNE DU JACOBIEN
C  ZONE DE TRAVAIL
C     SHP(6,NBNO)=TABLEAU DE TRAVAIL
C  OUTPUT
C     ISDJC = INDICATEUR SUR LE SIGNE DU JACOBIEN
C     NST =NBRE DE COLONNES DE LA MATRICE XGENE
C     DJAC=JACOBIEN
C     XGENE(NBNO,NST)=MATRICE (DE FONCTION DE FORME )
C     IRET= INDICATEUR  =  1 : SUCCES
C                       =  0 : ECHEC (ELEMENT INCOMPATIBLE )
C                       =  2 : ECHEC (JACOBIEN NUL         )
C=======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION XEL(3,*),XGENE((NBNO+NBNO),3),SHP(6,*),SHPTOT(6,NBNO,*)
C      PARAMETER(XZER=0.D0)
      IF (ITEL.EQ.126)              GOTO 10
C
C     ERREUR : TYPE D' ELEMENT  INCOMPATIBLE AVEC LA FORMULATION
C
      IRET = 0
      GOTO 666
  10  CONTINUE
      DO 101 NP=1,NBNO
      SHP(1,NP)=SHPTOT(1,NP,IGAU)
      SHP(2,NP)=SHPTOT(2,NP,IGAU)
      SHP(3,NP)=SHPTOT(3,NP,IGAU)
  101 CONTINUE
      CALL DEVOLU(XEL,SHP,MFR,NBNO,IFOU,NIFOU,2,1.D0,RR,DJAC)
C      WRITE(6,*)'RR=',RR
C      WRITE(6,*)'DJAC=',DJAC
C      WRITE(6,*)'SHP(1,1)=',SHP(1,1)
      IF (DJAC.LT.0.) ISDJC = ISDJC + 1
      IF ( DJAC.EQ.0.) GOTO 667
      DJAC = ABS(DJAC)
C
C     CAS DE L'ELEMENT QUAH
C
C
      NST = 2
      CALL ZERO(XGENE,NBNO,NST)
      DO 113 NP=1,NBNO
      XGENE(NP,1)=SHP(1,NP)
  113 CONTINUE
C
C     FONCTIONS DE FORME
 
      SHP(4,1)=SHP(1,1) + SHP(1,4)
      SHP(4,2)=SHP(1,2) + SHP(1,3)
      SHP(4,3)=0.D0
      SHP(4,4)=0.D0
C
      A1=MIN(XEL(2,1),XEL(2,2))
      A2=MIN(XEL(2,1),XEL(2,3))
      A3=MIN(XEL(2,1),XEL(2,4))
      A4=MIN(A1,A2)
      A5=MIN(A1,A3)
      Z1=MIN(A4,A5)
C      WRITE(6,*)'Z1',Z1
C
      B1=MAX(XEL(2,1),XEL(2,2))
      B2=MAX(XEL(2,1),XEL(2,3))
      B3=MAX(XEL(2,1),XEL(2,4))
      B4=MAX(B1,B2)
      B5=MAX(B1,B3)
      Z2=MAX(B4,B5)
C      WRITE(6,*)'Z2',Z2
C
      RH=Z2-Z1
      XZH=SHP(1,3) + SHP(1,4)
C
      S1=SHP(1,1) + SHP(1,4)
      S2=SHP(1,2) + SHP(1,3)
C
C     FONCTIONS DE FORME EN Z
C
      SHP(5,1)=1.D0-3.D0*XZH*XZH+2.D0*XZH*XZH*XZH
      SHP(5,2)=3.D0*XZH*XZH-2.D0*XZH*XZH*XZH
C
      SHP(5,3)=(RH*XZH)*(1.D0-2.D0*XZH+XZH*XZH)
      SHP(5,4)=(RH*XZH)*(XZH*XZH-XZH)
C
C     DERIVEES SECONDES / A Z DES FONCTIONS DE FORME EN Z
C
      SHP(6,1)=(-6.D0/(RH**2))+((12.D0/(RH**2))*XZH)
      SHP(6,2)=-1.D0*SHP(6,1)
      SHP(6,3)=(-4.D0/RH)+((6.D0/RH)*XZH)
      SHP(6,4)=(-2.D0/RH)+((6.D0/RH)*XZH)
C
C     DERIVEES SECONDES DES FONCTIONS DE FORME POUR LA FLEXION
C
C     POUR LES DEPLACEMENTS
C
      XGENE(1,2)=S1*SHP(6,1)
      XGENE(2,2)=S2*SHP(6,1)
      XGENE(3,2)=S2*SHP(6,2)
      XGENE(4,2)=S1*SHP(6,2)
C
C     POUR LES ROTATIONS
C
      XGENE(5,2)=S1*SHP(6,3)
      XGENE(6,2)=S2*SHP(6,3)
      XGENE(7,2)=S2*SHP(6,4)
      XGENE(8,2)=S1*SHP(6,4)
C
      IRET=1
C
      GOTO  666
 667  CONTINUE
C
C     JACOBIEN  NUL
C
      IRET = 2
C
 666  CONTINUE
      RETURN
      END