Sources Esope | Cast3M

elfgr0
C ELFGR0    SOURCE    CHAT      05/01/12    23:31:56     5004
      SUBROUTINE ELFGR0(KGREEN,DELTAT,NPAS,  KGREE2)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
************************************************************************
*
*                             E L F G R 0
*                             -----------
*
* FONCTION:
* ---------
*
*     TRANSFORMER LES FONCTIONS DE GREEN ET DERIVEES EN INTEGRALES SUR
*     LES PAS DE TEMPS DE CALCUL.
*
* MODULES UTILISES:
* -----------------
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMEVOLL
-INC SMLREEL
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
* -----------
*
*     KGREEN  (E)  OBJET "EVOLUTION" CONTENANT LES FONCTIONS DE GREEN.
*     DELTAT  (E)  PAS DE TEMPS DU CALCUL.
*     NPAS    (E)  NOMBRE DE PAS DE CALCUL.
*     KGREE2  (S)  OBJET "EVOLUTION" CONTENANT LES INTEGRALES DES
*                  FONCTIONS DE GREEN.
*
      REAL*8 DELTAT
*
* VARIABLES:
* ----------
*
      CHARACTER*72 ITEX
      LOGICAL TRACTI,TORSIO
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL MANIGOT     29 MARS 1988
*
* LANGAGE:
* --------
*
*     ESOPE + FORTRAN77
*
************************************************************************
*
      MEVOL1 = KGREEN
      SEGACT MEVOL1
      NBEL = MEVOL1.IEVOLL(/1)
      IF (MOD(NBEL,28).NE.0) THEN
*        IL MANQUE DES FONCTIONS DE GREEN
         CALL ERREUR(388)
         SEGDES MEVOL1
         RETURN
      END IF
*
      ITEX = MEVOL1.IEVTEX
      IND = INDEX(ITEX,'VERSION')
      IF (IND .NE. 0) THEN
         READ (ITEX(IND+7:IND+7),'(I1)') IVERS
      END IF
*
      IF (IND.EQ.0 .OR. IVERS.EQ.1) THEN
         KGREE2 = KGREEN
*        INUTILE DE DESACTIVER: CA VA RESSERVIR BIENTOT.
         RETURN
      END IF
*
*     ON DEPASSE LE TEMPS MINIMUM NECESSAIRE POUR PALIER A
*     DES ERREURS D'ARRONDI SUR DES CUMULS DE PAS DE TEMPS
      TMAX = (NPAS + 1) * DELTAT
*
*     CALCUL DES FONCTIONS INTEGRALES:
      TINI = 0.D0
      CALL SOMME1 (KGREEN,TINI,TMAX,DELTAT,  KGREE2)
      IF (IERR .NE. 0) RETURN
*
      MEVOLL = KGREE2
      SEGACT,MEVOLL,MEVOL1
      NBEL = NBEL/28 - 1
*
*
*     BOUCLAGE SUR LES DIFFERENTS TYPES DE POUTRES:
      DO 200 NB=0,NBEL
*
         DO 280 J=1,28
            TRACTI = J.EQ.1.OR.J.EQ.2.OR.J.EQ.15.OR.J.EQ.16
            TORSIO = J.EQ.3.OR.J.EQ.4.OR.J.EQ.17.OR.J.EQ.18
*
            KEVOLL = IEVOLL(NB*28+J)
            SEGACT KEVOLL
*
            IF (TRACTI.OR.TORSIO) THEN
*
               ITEX = KEVTEX
               READ (ITEX(24:35),FMT='(1PE12.5)') CT
               READ (ITEX(43:54),FMT='(1PE12.5)') RT
               CSR = CT / RT
               CSR1 = - CSR
               MLREEL = IPROGY
               SEGACT MLREEL
               NBINTG = PROG(/1)
*
               IF ((J/2)*2 .NE. J) THEN
*              INTEGRALE DE "G"
                  CALL MULVE1 (CSR,PROG,NBINTG)
                  IF (IIMPI .EQ. 1806) THEN
                     IF (TRACTI) THEN
                        WRITE (IOIMP,*) 'INTEGRALE DE G'
                        WRITE (IOIMP,*) (PROG(NP),NP=1,NBINTG)
                     END IF
                  END IF
               ELSE
*              INTEGRALE DE "DG/DX"
                  CALL MULVE1 (CSR1,PROG,NBINTG)
                  IF (IIMPI .EQ. 1806) THEN
                     IF (TRACTI) THEN
                        WRITE (IOIMP,*) 'INTEGRALE DE DG/DX'
                        WRITE (IOIMP,*) (PROG(NP),NP=1,NBINTG)
                     END IF
                  END IF
               END IF
*
               SEGDES,MLREEL
*
            ELSE
*              FLEXION
*
*+*            READ (ITEX(43:54),FMT='(1PE12.5)') RFZ
*
*              EN FLEXION, LA VERSION 2 N'EXISTE PAS ENCORE. LES
*              INTEGRALES CALCULEES SONT BIDON ET LES BONNES SONT DANS
*              LE "KEVOLL" ORIGINEL:
*
               KEVOL1 = MEVOL1.IEVOLL(NB*28+J)
               SEGACT,KEVOL1
               MLREE1 = KEVOL1.IPROGY
               SEGINI,MLREEL=MLREE1
               IPROGY = MLREEL
               SEGDES,MLREEL
               SEGDES,KEVOL1
*
            END IF
*
            SEGDES,KEVOLL
*
  280       CONTINUE
*        END DO
*
  200    CONTINUE
*     END DO
*
      SEGDES,MEVOLL,MEVOL1
*
      END