Sources Esope | Cast3M

calp
C CALP      SOURCE    CB215821  22/07/20    15:39:38     11411          
      SUBROUTINE CALP
*
*
*     AUTEUR : J.BRUN (AVRIL 90)
*
*-----------------------------------------------------------
*     BUT :
*        ENTETE DE L'OPERATEUR SERVANT A CALCULER LES CONTRAINTES
*        OU LES DEFORMATIONS EN PEAU OU AU PLAN MOYEN
*
*
*----------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
*
-INC SMCHAML
 
-INC PPARAM
-INC CCOPTIO
*
      CHARACTER*4 LMOT(3),LOC
      DATA        LMOT/'INFE','MOYE','SUPE'/
      NBMOT=3
*----------------------------------------------------------
*
*        LECTURE DES PARAMETRES EN ENTREE
*
*----------------------------------------------------------
*
*        LECTURE DE 2 CHAMELEMS QUELCONQUES
*
      CALL LIROBJ('MCHAML  ',IPTS1,1,IOK)
      CALL ACTOBJ('MCHAML  ',IPTS1,1)
      IF (IERR.NE.0) RETURN
      CALL LIROBJ('MCHAML  ',IPTS2,1,IOK)
      CALL ACTOBJ('MCHAML  ',IPTS2,1)
      IF (IERR.NE.0) RETURN
*
*        DETECTION DE LA PRESENCE D'UN MCHAML  SCALAIRE  (T)
*               pour option  T  --->  TINF T TSUP
      ITEMP=0
      MCHELM=IPTS1
      SEGACT MCHELM
      IF (TITCHE(1:12).EQ.'SCALAIRE    ') THEN
        ITEMP=IPTS1
            SEGDES MCHELM
        GOTO 1000
      ENDIF
      SEGDES MCHELM
      MCHELM=IPTS2
      SEGACT MCHELM
      IF (TITCHE(1:12).EQ.'SCALAIRE    ') THEN
        ITEMP=IPTS2
            SEGDES MCHELM
        GOTO 1000
      ENDIF
      SEGDES MCHELM
 
*----------------------------------------------------------------------
*    1ere FONCTION
*----------------------------------------------------------------------
 
*
*        DETECTION DE LA PRESENCE D'UN MCHAML DE DEFORMATION
*
      IDEFO=0
      MCHELM=IPTS1
      SEGACT MCHELM
      IF (TITCHE(1:12).EQ.'DEFORMATIONS') THEN
        IDEFO=1
      ENDIF
      SEGDES MCHELM
      MCHELM=IPTS2
      SEGACT MCHELM
      IF (TITCHE(1:12).EQ.'DEFORMATIONS') THEN
        IDEFO=1
      ENDIF
      SEGDES MCHELM
 
*
      IF (IDEFO.EQ.1) THEN
        CALL RNGCHA(IPTS1,IPTS2,'DEFORMATIONS','CARACTERISTIQUES',
     1              IPTR1,IPTR2)
      ELSE
        CALL RNGCHA(IPTS1,IPTS2,'CONTRAINTES','CARACTERISTIQUES',
     1              IPTR1,IPTR2)
      ENDIF
      IF(IERR.NE.0) RETURN
*
*    ... CHAMELEM tensoriel ...
*
      IF(IPTR1.EQ.0) THEN
         MOTERR(1:16)='CONTRAINTES     '
         CALL ERREUR(291)
         RETURN
      ENDIF
*
*    ... CHAMELEM DE CARACTERISTIQUES ...
*
      IF(IPTR2.EQ.0) THEN
         MOTERR(1:16)='CARACTERISTIQUES'
         CALL ERREUR(291)
         RETURN
      ENDIF
*
*     ... MODELE ...
*
      CALL LIROBJ('MMODEL  ',IPTR3,1,IOK)
      CALL ACTOBJ('MMODEL  ',IPTR3,1)
      IF (IERR.NE.0) RETURN
      CALL ACTOBJ('MMODEL  ',IPTR3,1)
 
      IPIN=IPTR1
      CALL ACTOBJ('MCHAML  ',IPIN,1)
      CALL REDUAF(IPIN,IPTR3,IPTR1,0,IR,KER)
      IF(IR   .NE. 1) CALL ERREUR(KER)
      IF(IERR .NE. 0) RETURN
 
      IPIN=IPTR2
      CALL ACTOBJ('MCHAML  ',IPIN,1)
      CALL REDUAF(IPIN,IPTR3,IPTR2,0,IR,KER)
      IF(IR   .NE. 1) CALL ERREUR(KER)
      IF(IERR .NE. 0) RETURN
*
*    ... PLAN DE SORTIE DES RESULTATS ...
*
      LOC='MOYE'
      CALL LIRMOT(LMOT,NBMOT,ILOC,0)
      IF (ILOC.NE.0) LOC=LMOT(ILOC)
*
*    ... Le calcul lui-même ...
*
      IF (IDEFO.EQ.1) THEN
          CALL CALP2(IPTR1,IPTR2,IPTR3,LOC,IPTR)
      ELSE
          CALL CALP1(IPTR1,IPTR2,IPTR3,LOC,IPTR)
      ENDIF
*
*    ... Sortie du résultat ...
*
      IF(IERR.EQ.0) THEN
        CALL ACTOBJ('MCHAML  ',IPTR,1)
        CALL ECROBJ('MCHAML  ',IPTR)
      ENDIF
C
      RETURN
 
*----------------------------------------------------------------------
*    2nd FONCTION
*----------------------------------------------------------------------
 
1000  CONTINUE
 
*   projection d un champ de temperature calcule sur un massif
*       sur des coques  en TINF     T   et TSUP
*
*     Lecture du modele de coque.
*
      CALL LIROBJ('MMODEL  ',IPMODE,1,IRET)
      CALL ACTOBJ('MMODEL  ',IPMODE,1)
      IF (IERR.NE.0) RETURN
 
C   on verifie que c est bien un modele de coques
C   identification  du champ original de temperature et des
C   caracteristiques
      IPCHT=itemp
C
      if(ipcht.eq.ipts1) then
      ipche= ipts2
      else
      ipche=ipts1
      endif
 
      call prot(ipmode,ipcht,ipche,iptr)
      IF(IERR.EQ.0) THEN
        CALL ACTOBJ('MCHAML  ',IPTR,1)
        CALL ECROBJ('MCHAML  ',IPTR)
      ENDIF
*
      return
      END