Sources Esope | Cast3M

form
C FORM      SOURCE    OF166741  24/06/06    21:15:02     11934          
 
C=======================================================================
C=                             F O R M                                 =
C=                             -------                                 =
C=                                                                     =
C=  FONCTEUR CAST3M 'FORME' DE MISE A JOUR DE CONFIGURATIONS :         =
C=  ----------------------------------------------------------         =
C=   (CONF2) (CAR2)  =  'FORME'  (CONF1)  (CHPO1)  (MODL1  CAR1) ;     =
C=                                                                     =
C= UTILISATION : SANS OPERANDE MET DANS LA PILE LE SEGMENT MCOORD
C=             : AVEC UN OBJET CONFIGURA, ACTIVE CETTE CONFIGURATION
C=             : AVEC UN CHAMPOINT, CREE LES COORD = COURANTES+DEFORMEE
C=               PUIS ACTIVE CETTE CONFIG
C=             : AVEC CHPOINT ET CONFIGUR  CREE ET ACTIVE LA CONFIGU =
C=                    CONFIGUR + DEFORMEE ISSU DE CHPOINT.
C= SERT A NOMMER, ACTIVER OU CREER UNE CONFIGURATION C'EST-A-DIRE UN
C= CHAMP DE COORDONNEES SUPPORT.
C=                                                                     =
C=  ARGUMENTS :                                                        =
C=  -----------                                                        =
C=   CONF1   (CONFIGU)  Champ de coordonnees support (configuration)   =
C=   CHPO1   (CHPOINT)  Champ de deplacements sur la structure         =
C=   MODL1   (MMODEL)   Modele de la structure etudiee    (facultatif) =
C=   CAR1    (MCHAML)   Caracteristiques geometriques     (facultatif) =
C=                      Sous-type 'CARACTERISTIQUES'                   =
C=                                                                     =
C=  RESULTATS :                                                        =
C=  -----------                                                        =
C=   CONF2   (CONFIGU)  Champ de coordonnees support actualise         =
C=   CAR2    (MCHAML)   Caracteristiques geometriques actualisees      =
C=======================================================================
 
      SUBROUTINE FORM
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC CCASSIS
 
-INC SMCOORD
      POINTEUR MXCA.MCOORD
-INC SMELEME
-INC SMCHPOI
 
      LOGICAL BUR
      CHARACTER*(LOCOMP) MDDL
      CHARACTER*(LOCOMP) NODEF(3),NODEG(3)
 
      DATA NODEF / 'UX  ','UY  ','UZ  ' /
      DATA NODEG / 'UR  ','UZ  ','UT  ' /
 
C *   attention aux assistants ....
      if (NBESC.NE.0) then
          if (iimpi .eq. 1234)
 
     &  write(ioimp,*) ' il faut bloquer les assistants'
      ith=0
      ith=oothrd
      if(ith.ne.0) then
          call erreur (1010)
          return
      endif
       do ith=1,nbesc
          mesins= mescl(ith)
          segact mesins
  20      if(nbins.ne.0) then
*         write(6,*)'on attend la fin des esclaves ith nbins',ith,nbins
             segdes mesins*record
             segact mesins*(mod,ecr=1)
             go to 20
          endif
          segdes mesins*record
        enddo
        mestra=imestr
        SEGACT MESTRA*MOD
        if (iimpi .eq. 1234)
     &    write(ioimp,*) ' assistants en attente'
      end if
 
      SEGACT,MCOORD*mod
c*      NBPTX=XCOOR(/1)/idimp1
c*      NBPTX=NBPTS
 
      MCOO   = 0
      IPTC   = 0
      IPMODL = 0
 
      CALL LIROBJ('CONFIGUR',MCOO,0,IRET)
      CALL LIROBJ('CHPOINT ',IPTC,0,IRET)
      CALL LIROBJ('MMODEL  ',IPMODL,0,IRET)
      IF (IERR.NE.0) GOTO 10
 
      IF (IPTC .NE. 0) THEN
        CALL ACTOBJ('CHPOINT ',IPTC,1)
      ENDIF
 
C= Cas d'un MCHAML de CARACTERISTIQUES a TRANSPORTER
      IF (IPMODL .NE. 0) THEN
        IF (IPTC.EQ.0) THEN
          MOTERR(1:8)='CHPOINT'
          CALL ERREUR(37)
          RETURN
        ENDIF
        CALL LIROBJ('MCHAML  ',IPIN,1,IRET)
        IF (IERR .NE. 0) GOTO 10
 
        CALL ACTOBJ('MMODEL  ',IPMODL,1)
        CALL ACTOBJ('MCHAML  ',IPIN  ,1)
 
        CALL REDUAF(IPIN,IPMODL,IPCH1,0,IR,KER)
        IF (IR   .NE. 1) CALL ERREUR(KER)
        IF (IERR .NE. 0) GOTO 10
 
C       Mise a jour des caracteristiques materielles
        CALL FORMCH(IPMODL,IPCH1,IPTC,IRET,IPCH2)
        IF (IRET.EQ.0.OR.IERR.NE.0) GOTO 10
        CALL ACTOBJ('MCHAML  ',IPCH2,1)
        CALL ECROBJ('MCHAML  ',IPCH2)
        IF (IERR .NE. 0) GOTO 10
c-dbg        call zpchel(ipch1,0)
c-dbg        call zpchel(ipch2,0)
      ENDIF
 
      idimp1=IDIM+1
      IF (IPTC.EQ.0) THEN
        IF (MCOO.EQ.0) THEN
          SEGINI,MXCA=MCOORD
          CALL ECROBJ('CONFIGUR',MXCA)
        ELSE
          MXCA=MCOO
          SEGACT,MXCA
          NBPTA=MXCA.XCOOR(/1)/idimp1
          IF (NBPTA.NE.NBPTX) THEN
c*            NBPTS=NBPTX
            SEGADJ,MXCA
            DO i=NBPTA*idimp1+1,NBPTS*idimp1
              MXCA.XCOOR(i)=XCOOR(i)
            ENDDO
          ENDIF
          MCOORD=MXCA
        ENDIF
 
      ELSE
C  Mise a jour des coordonnes en ajoutant le champ de deplacement
        IF (MCOO.NE.0) THEN
          MXCA=MCOO
          SEGACT,MXCA
          NBPTA=MXCA.XCOOR(/1)/idimp1
          IF (NBPTA.NE.NBPTX) THEN
c*            NBPTS=NBPTX
            SEGADJ,MXCA
            DO i=NBPTA*idimp1+1,NBPTS*idimp1
              MXCA.XCOOR(i)=XCOOR(i)
            ENDDO
          ENDIF
          MCOORD=MXCA
        ENDIF
 
        IF (IFOMOD.EQ.0.OR.IFOMOD.EQ.1) THEN
          BUR=.TRUE.
          NCMAX=2
        ELSE IF (IFOMOD.EQ.4.OR.IFOMOD.EQ.5) THEN
          BUR=.TRUE.
          NCMAX=1
        ELSE IF (IFOMOD.EQ.-1) THEN
          BUR=.FALSE.
          NCMAX=2
        ELSE IF (IFOMOD.EQ.3) THEN
          BUR=.FALSE.
          NCMAX=1
        ELSE
          BUR=.FALSE.
          NCMAX=3
        ENDIF
 
        SEGINI,MXCA=MCOORD
        MCHPOI=IPTC
        DO iSoup=1,IPCHP(/1)
          MSOUPO=IPCHP(iSoup)
          MPOVAL=IPOVAL
          IPT2=IGEOC
          NbElt=IPT2.NUM(/2)
          DO IC=1,NOCOMP(/2)
            MDDL=NOCOMP(IC)
            DO INUM=1,NCMAX
              IF (BUR) THEN
                IF (NODEG(INUM).EQ.MDDL) GOTO 81
              ELSE
                IF (NODEF(INUM).EQ.MDDL) GOTO 81
              ENDIF
            ENDDO
            GOTO 70
 81         DO iElt=1,NbElt
              IP=(IPT2.NUM(1,iElt)-1)*idimp1+INUM
              MXCA.XCOOR(IP)=MXCA.XCOOR(IP)+VPOCHA(iElt,IC)
            ENDDO
 70         CONTINUE
          ENDDO
        ENDDO
        MCOORD=MXCA
        SEGDES,MCOORD
        CALL ECROBJ('CONFIGUR',MCOORD)
      ENDIF
 
 10   CONTINUE
C *   attention aux assistants ....
      if (NBESC.NE.0) then
C *     il faut liberer le segment de dialogue
        mestra=imestr
        SEGDES MESTRA
      end if
 
c      return
      END