Sources Esope | Cast3M

green
C GREEN     SOURCE    FANDEUR   10/12/14    21:16:58     6812
C
      SUBROUTINE GREEN
C ======================================================================
C     FABRICATION D'UN OBJET EVOLUTION CONTENANT LES FONCTIONS
C     DE GREEN D'UN ELEMENT DE POUTRE
C
C     EVOL1 = GREEN  STR1  TEMPS DT1
C             I BERNOUILLI-EULER I NON-FILTRE
C             I                  I FILTRE FREQ1 FREQ2 (AMORTISSEMENT EPS
C             I
C             I TIMOSHENKO FILTRE FREQ1 FREQ2 (AMORTISSEMENT EPS)
C
C     STR1     : OBJET STRUCTURE CONTENANT L'ELEMENT DE POUTRE
C     TEMPS    : VALEUR DU TEMPS DE CALCUL
C     DT1      : VALEUR DU PAS DE TEMPS
C
C     2 MODELES POSSIBLES : BERNOUILLI-EULER OU TIMOSHENKO
C     FILTRE   : FONCTIONS DE GREEN FILTREES
C     FREQ1    : FREQUENCE BASSE DE FILTRAGE
C     FREQ2    : FREQUENCE HAUTE DE FILTRAGE
C
C     POUR LES FONCTIONS DE GREEN FILTREES EN OPTION :
C     AMORTISSEMENT DE VALEUR EPS
C
C     L ACCES AUX VERSIONS 2 ET 3 EST SUPPRIME AINSI QUE L UTILISATION
C     D UN FILTRE F1 F2
C
C     EVOL1    : OBJET EVOLUTION CONTENANT LES FCTS DE GREEN
C
C     PROGRAMMEUR : GUILBAUD
C     CREATION    : 21/09/87
C     MODIFICATIONS: LIONEL VIVAN    18/02/88
C                  : PASCAL MANIGOT  22/02/88
C                  : XAVIER VACELET  09/01/89
C ======================================================================
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCREEL
 
-INC SMCHAML
-INC SMCOORD
-INC SMELEME
-INC SMSTRUC
      PARAMETER (NBRMOT=3)
      CHARACTER*8 LISMOT(NBRMOT)
      DATA LISMOT/'FILTRE  ','VERSION ','INTEGRAT'/
C
      CALL LIROBJ ('STRUCTUR',MSTRUC,1,IRETOU)
      IF(IERR.NE.0) RETURN
      SEGACT MCOORD
      SEGACT MSTRUC
      NSTR= LISTRU(/1)
      IF(NSTR.NE.1) THEN
C *** LA SOUS-STRUCTURE DOIT ETRE ELEMENTAIRE
        INTERR(1)=MSTRUC
        CALL ERREUR(90)
        RETURN
      ENDIF
      MSOSTU =LISTRU(1)
      SEGACT MSOSTU
      MCHELM=ISCHAM(1)
      MCHEL1=ISCHAM(2)
      SEGDES MSOSTU
      IF(MCHELM.EQ.0.OR.MCHEL1.EQ.0) THEN
C *** LA SOUS-STRUCTURE DOIT ETRE DEFINIE A PARTIR DES CHAMPS PAR ELEMEN
        INTERR(1)=MSOSTU
        CALL ERREUR(376)
        RETURN
      ENDIF
      SEGACT MCHELM,MCHEL1
      NSOUS=IMACHE(/1)
      IF(NSOUS.NE.1) THEN
C *** LA SOUS-STRUCTURE DOIT ETRE COMPOSEE D'UNE SEULE ZONE D'ELEMENTS
        INTERR(1)=MSOSTU
        CALL ERREUR(377)
        RETURN
      ENDIF
      MELEME=IMACHE(1)
      SEGACT MELEME
      IF(ITYPEL.NE.2) THEN
C *** LA SOUS-STRUCTURE DOIT ETRE COMPOSEE D'ELEMENTS SEG2
        INTERR(1)=MSOSTU
        CALL ERREUR(378)
        RETURN
      ENDIF
      NBELEM=NUM(/2)
      IF(NBELEM.NE.1) THEN
C *** LA SOUS-STRUCTURE DOIT ETRE COMPOSEE D'UN SEUL ELEMENT
        INTERR(1)=MSOSTU
        CALL ERREUR(379)
        RETURN
      ENDIF
C
      NCOO1=(NUM(1,1)-1)*(IDIM+1)
      NCOO2=(NUM(2,1)-1)*(IDIM+1)
      XE1=XCOOR(NCOO1+1)
      XE2=XCOOR(NCOO2+1)
      YE1=XCOOR(NCOO1+2)
      YE2=XCOOR(NCOO2+2)
      ZE1=XCOOR(NCOO1+3)
      ZE2=XCOOR(NCOO2+3)
      XL=XE2-XE1
      YL=YE2-YE1
      ZL=ZE2-ZE1
      DLL=SQRT(XL*XL+YL*YL+ZL*ZL)
      SEGDES MELEME
C
      KMATER=ICHAML(1)
      KCARAC=MCHEL1.ICHAML(1)
C
      SEGDES MCHELM,MCHEL1
      SEGDES MSTRUC
      IF(DLL.EQ.0.D0) THEN
C *** L'ELEMENT EST DE LONGUEUR NULLE
        INTERR(1)=MSOSTU
        CALL ERREUR(381)
        RETURN
      ENDIF
C
      CALL LIRREE (TEMPS,1,IRETOU)
      IF(IERR.NE.0) RETURN
      CALL LIRREE (DT1,1,IRETOU)
      IF(IERR.NE.0) RETURN
      IF ((TEMPS.LE.0.D0) .OR. (DT1.LE.0.D0)) THEN
C        VALEURS DE TEMPS NEGATIVES OU NULLES
         CALL ERREUR(414)
         RETURN
      END IF
      IF (TEMPS.LT.DT1) THEN
         FA=TEMPS
         TEMPS=DT1
         DT1=FA
      END IF
*
      IVERS = 1
      F1=0.D0
      F2=0.D0
      NIN0 = 4
      NIN = NIN0
      DO 10 I=1,NBRMOT
         CALL LIRMOT(LISMOT,NBRMOT,IMOT,0)
         IF (IMOT.LE.0) THEN
*           EXIT
            GOTO 20
         END IF
         IF (IMOT.EQ.1) THEN
            CALL LIRREE (F1,1,IRETOU)
            IF (IERR.NE.0) RETURN
            CALL LIRREE (F2,1,IRETOU)
            IF (IERR.NE.0) RETURN
            IF ((F1.LT.0.D0) .OR. (F2.LT.0.D0)) THEN
C              FREQUENCE DE FILTRE NEGATIVE
               CALL ERREUR(375)
               RETURN
            END IF
            IF (F2.LT.F1) THEN
               FA=F1
               F1=F2
               F2=FA
            END IF
         ELSE IF (IMOT.EQ.2) THEN
            CALL LIRENT (IVERS,1,IRETOU)
            IF (IERR.NE.0) RETURN
         ELSE IF (IMOT.EQ.3) THEN
            CALL LIRENT (NIN,1,IRETOU)
            IF (IERR.NE.0) RETURN
            IF (NIN.LT.1 .OR. NIN.GT.4) THEN
               INTERR(1) = NIN
               NIN=NIN0
               INTERR(2) = NIN
               CALL ERREUR(413)
            END IF
         END IF
10    CONTINUE
20    CONTINUE
C
      IF (IVERS .EQ. 2) THEN
         CALL GREEN2 (KMATER,KCARAC,DLL,TEMPS,DT1,F1,F2,NIN,  IGREEN)
      ELSE IF (IVERS .EQ. 3) THEN
         CALL GREEN3 (KMATER,KCARAC,DLL,TEMPS,DT1,F1,F2,NIN,  IGREEN)
      ELSE
         CALL GREEN1 (KMATER,KCARAC,DLL,TEMPS,DT1,F1,F2,  IGREEN)
      END IF
C
      CALL ECROBJ ('EVOLUTIO',IGREEN)
C
      RETURN
      END