Sources Esope | Cast3M

pouvlo
C POUVLO    SOURCE    PV090527  24/09/04    07:45:32     12000          
      SUBROUTINE POUVLO(IPMODL,MLMOTS,ISUP,ICARA)
*-----------------------------------------------------------------------
*           ADDITION DU VECTEUR LOCAL POUR LES POUTRES
*                ET LES TUYAUX S'IL EST ABSENT EN 3D
*-----------------------------------------------------------------------
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
* -----------
*
*     IPMODL  (E)   POINTEUR D'OBJET MODELE
*     MLMOTS  (E)   POINTEUR SUR LE LISTMOTS DE CARACTERISTIQUES
*     ISUP    (E)   NUMERO DE SUPPORT DEMANDE
*     ICARA  (E+S)  POINTEUR SUR LE CHAMELEM
*
* LANGAGE:
* --------
*
*     ESOPE + FORTRAN77
*
*-----------------------------------------------------------------------
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 XEPOU(3,2),VECT(3)
 
-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC SMCHAML
-INC SMMODEL
-INC SMLMOTS
-INC SMELEME
-INC SMCOORD
*
*      SEGMENT INFO
*       INTEGER INFELE(JG)
*      ENDSEGMENT
      CHARACTER*(NCONCH)  CONM
*
       segact mcoord
      SEGACT,MLMOTS
*
*     LE VECTEUR EXISTE T-IL DEJA ?
*
      IVECT=0
      IVECX=0
      IVECY=0
      IVECZ=0
      DO 1 I=1,MOTS(/2)
      IF(MOTS(I).EQ.'VECT') THEN
         ivecT=1                  
      ENDIF
      IF(MOTS(I).EQ.'VX') THEN
         ivecx=1                  
      ENDIF
      IF(MOTS(I).EQ.'VY') THEN
         ivecy=1                  
      ENDIF
      IF(MOTS(I).EQ.'VZ') THEN
         ivecz=1                  
      ENDIF
   1  CONTINUE
*  vecx vecy vecz existent. C'est OK
      if(ivecx.eq.1.and.ivecy.eq.1.and.ivecz.eq.1) then   
       if (ivect.eq.0) then
         return                 
       else
         moterr='VECT'
         call erreur(7)
         return                 
       endif
      endif
 
*
*     ACTIVATIONS
*
      MMODEL=IPMODL
      NSOUS=KMODEL(/1)
      MCHELM=ICARA
      SEGACT MCHELM
*
*     BOUCLE SUR LES SOUS ZONES DU MODELE
*
      DO 200 ISOUS=1,NSOUS
*
*     TRAITEMENT DU MODELE
*
      IMODEL=KMODEL(ISOUS)
      MELE  =NEFMOD
      IPMAIL=IMAMOD
      CONM  =CONMOD
*
*
*     INFORMATIONS SUR L'{L{MENT FINI
*
*      CALL ELQUOI(MELE,0,ISUP,INFO,IMODEL)
      IF (IERR.NE.0) THEN
**       SEGDES MCHELM
         RETURN
      ENDIF
      MFR =INFELE(13)
      IF(MFR.NE.7.AND.MFR.NE.13) THEN
*         SEGSUP INFO
         GO TO 200
      ENDIF
*
*     RECHERCHE DE LA ZONE DU CHAMELEM
*
      N1  = IMACHE(/1)
      N3  = INFCHE(/2)
      LAZON = 0
      DO 11 I=1,N1
         IF (IPMAIL.NE.IMACHE(I) .OR.
     .         CONM.NE.CONCHE(I)) GO TO 11
            LAZON=I
            GO TO 12
 11   CONTINUE
*
      CALL ERREUR(472)
**    SEGDES MCHELM
*      SEGSUP INFO
      RETURN
*
 12   CONTINUE
      MCHAML=ICHAML(LAZON)
      SEGACT MCHAML
      N2=NOMCHE(/2)
 
* y a t'il VECT
      ivect=0
      do i=1,n2
        if (nomche(i).eq.'VECT') ivect=i
 
      enddo
      melval=0
      if(ivect.ne.0) then
       melval=ielval(ivect)
       segact melval
      endif
 
 
      N2=N2+3
      SEGADJ MCHAML
      NOMCHE(N2-2)='VX'
      TYPCHE(N2-2)='REAL*8' 
      NOMCHE(N2-1)='VY'
      TYPCHE(N2-1)='REAL*8' 
      NOMCHE(N2  )='VZ'
      TYPCHE(N2  )='REAL*8' 
      MELEME=IPMAIL
      SEGACT MELEME
      NBNN=NUM(/1)
*
*  CREATION DU MELVAL ET REMPLISSAGE
*
      N2EL=0
      N2PTEL=0
      N1EL=NUM(/2)
      N1PTEL=1
      SEGINI MELVA1
      IELVAL(N2-2)=MELVA1
      SEGINI MELVA2
      IELVAL(N2-1)=MELVA2
      SEGINI MELVA3
      IELVAL(N2  )=MELVA3
*
            DO 305 ID=1,N1EL
            CALL DOXE(XCOOR,IDIM,NBNN,NUM,ID,XEPOU)
            CALL POULOC(XEPOU,VECT,KERRE)
            IF(KERRE.NE.0) THEN
              INTERR(1)=ISOUS
              INTERR(2)=ID
              CALL ERREUR(128)
**            SEGDES MELEME
**            SEGDES MELVA1,melva2,melva3,MCHAML,MCHELM,MLMOTS
*              SEGSUP INFO
            ENDIF
*
*           CREATION DU VECTEUR
*
            if (melval.eq.0) then
            MELVA1.VELCHE(1,ID)=VECT(1)
            MELVA2.VELCHE(1,ID)=VECT(2)
            MELVA3.VELCHE(1,ID)=VECT(3)
            else
            ipt=melval.ielche(1,min(melval.ielche(/2),id))
            MELVA1.VELCHE(1,ID)=xcoor((ipt-1)*(idim+1)+1)
            MELVA2.VELCHE(1,ID)=xcoor((ipt-1)*(idim+1)+2)
            MELVA3.VELCHE(1,ID)=xcoor((ipt-1)*(idim+1)+3)
            endif
  305       CONTINUE
*
*     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
*
**    SEGDES MELEME
**    SEGDES MELVA1,melva2,melva3
*      SEGSUP INFO
*  suppression de VECT si il etait la
      if(ivect.ne.0) then
         do i=ivect+1,ielval(/1)
           nomche(i-1)=nomche(i)
           typche(i-1)=typche(i)
           ielval(i-1)=ielval(i)
         enddo
         n2=ielval(/1)-1
         segadj mchaml
      endif
**    SEGDES MCHAML
  200 CONTINUE
*
**    SEGDES MCHELM
**    SEGDES,MLMOTS
      RETURN
      END