Sources Esope | Cast3M

form
C FORM      SOURCE    CB215821  20/11/25    13:29:14     10792          
 
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 METS DANS LA PILE LE SEGMENT CCOORD
C=             : AVEC UN OBJET CONFIGURA, ACTIVE CETTE CONFIGURATION
C=             : AVEC UN CHAMPOINT, CREE LES COORDO = 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 SMCOORD
      POINTEUR MXCA.MCOORD
-INC SMELEME
-INC SMCHPOI
-INC CCASSIS
 
      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
 
      CALL LIROBJ('CONFIGUR',MCOO,0,IRET1)
      CALL LIROBJ('CHPOINT ',IPTC,0,IRET2)
      CALL LIROBJ('MCHAML  ',IPIN,0,IRET3)
      IPCH1 = 0
 
      IF (IRET3.NE.0) THEN
        CALL ACTOBJ('MCHAML  '  ,IPIN,1)
        IF (IRET2.EQ.0) THEN
          MOTERR(1:8)='CHPOINT'
          CALL ERREUR(37)
          RETURN
        ENDIF
        CALL ACTOBJ('CHPOINT ',IPTC,1)
 
        CALL LIROBJ('MMODEL',IPMODL,1,IRET)
        IF (IRET.EQ.0 .OR. IERR.NE.0) go to 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) RETURN
 
C       Mise a jour des caracteristiques materielles
        CALL FORMCH(IPMODL,IPCH1,IRET,IPTC,IPCH2)
        IF (IRET.EQ.0.OR.IERR.NE.0) RETURN
        CALL ACTOBJ('MCHAML  ',IPCH2,1)
        CALL ECROBJ('MCHAML  ',IPCH2)
      ENDIF
 
      idimp1=IDIM+1
      IF (IPTC.EQ.0) THEN
        IF (MCOO.EQ.0) THEN
          SEGINI,MXCA=MCOORD
          SEGDES,MXCA
          CALL ECROBJ('CONFIGUR',MXCA)
          go to 10
        ELSE
          MXCA=MCOO
          SEGACT,MXCA
          NBPTA=MXCA.XCOOR(/1)/idimp1
          NBPTS=XCOOR(/1)/idimp1
          SEGADJ,MXCA
          DO i=NBPTA*idimp1+1,NBPTS*idimp1
            MXCA.XCOOR(i)=XCOOR(i)
          ENDDO
          MCOORD=MXCA
          go to 10
        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
          NBPTS=XCOOR(/1)/idimp1
          SEGADJ,MXCA
          DO i=NBPTA*idimp1+1,NBPTS*idimp1
            MXCA.XCOOR(i)=XCOOR(i)
          ENDDO
          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
        SEGACT,MCHPOI
        DO iSoup=1,IPCHP(/1)
          MSOUPO=IPCHP(iSoup)
          SEGACT,MSOUPO
          MPOVAL=IPOVAL
          SEGACT,MPOVAL
          IPT2=IGEOC
          SEGACT,IPT2
          NbElt=IPT2.NUM(/2)
          DO 70 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
        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
 
      END