C FORM SOURCE PV090527 25/06/11 21:15:08 12279 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 character*16 icha LOGICAL BUR,ROT CHARACTER*(LOCOMP) MDDL CHARACTER*(LOCOMP) NODEF(3),NODEG(3) CHARACTER*(LOCOMP) RODEF(3),RODEG(3) DATA NODEF / 'UX ','UY ','UZ ' / DATA NODEG / 'UR ','UZ ','UT ' / DATA RODEF / 'RX ','RY ','RZ ' / DATA RODEG / 'RR ','RZ ','RT ' / 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 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 ** write(6,*) 'form mcoo iptc ipmodl',mcoo,iptc,ipmodl IF (MCOO.EQ.0.AND.IPTC.EQ.0) THEN * il faut rendre la configuration courante segact mcoord mrotat=mrota CALL ECROBJ('CONFIGUR',MCOORD) goto 10 ENDIF 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,MCOORD) IF (IRET.EQ.0.OR.IERR.NE.0) GOTO 10 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 IF(MXCA.NE.MCOORD) THEN MXCA=MCOO SEGACT,MXCA NBPTA=MXCA.XCOOR(/1)/idimp1 IF (NBPTA.NE.NBPTS) THEN SEGADJ,MXCA DO i=NBPTA*idimp1+1,NBPTS*idimp1 MXCA.XCOOR(i)=XCOOR(i) ENDDO ENDIF MCOORD=MXCA ENDIF ENDIF IF (IPMODL .NE. 0) THEN mclcnf=mcoord CALL ACTOBJ('MCHAML ',IPCH2,1) 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.NBPTS) THEN SEGADJ,MXCA DO i=NBPTA*idimp1+1,NBPTS*idimp1 MXCA.XCOOR(i)=XCOOR(i) ENDDO ENDIF MCOORD=MXCA ENDIF bur=((ifour.eq.0).or.(ifour.eq.1)) ncmax=3 ** write(6,*) 'FORM ifomod ifour',ifomod,ifour ROT=.FALSE. MCHPOI=IPTC ** call ecchpo(mchpoi,1) DO iSoup=1,IPCHP(/1) MSOUPO=IPCHP(iSoup) MPOVAL=IPOVAL DO IC=1,NOCOMP(/2) MDDL=NOCOMP(IC) DO INUM=1,3 IF (BUR) THEN IF (RODEG(INUM).EQ.MDDL) ROT=.TRUE. ELSE IF (RODEF(INUM).EQ.MDDL) ROT=.TRUE. ENDIF ENDDO ENDDO ENDDO ** write(6,*) 'form bur rot',bur,rot,ncmax,ifomod,ifour SEGINI,MXCA=MCOORD * definition eventuelle des rotations MROTA1=0 MROTAT=0 IF(ROT) THEN IF (MROTA.NE.0) THEN MROTAT=MROTA SEGINI,MROTA1=MROTAT ELSE idimr=3 SEGINI,MROTA1 ** write(6,*) 'mrota1',mrota1 ENDIF MXCA.MROTA=MROTA1 ENDIF 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 IF(ROT) THEN DO INUM=1,3 IF (BUR) THEN IF (RODEG(INUM).EQ.MDDL) GOTO 82 ELSE IF (RODEF(INUM).EQ.MDDL) GOTO 82 ENDIF ENDDO GOTO 71 82 DO iElt=1,NbElt IP=IPT2.NUM(1,iElt) MROTA1.XROTA(inum,ip)=MROTA1.XROTA(inum,IP)+ > VPOCHA(iElt,IC) ENDDO 71 CONTINUE ENDIF ENDDO ENDDO IF(MROTA.NE.0) SEGDES MROTA SEGDES MCOORD MCOORD=MXCA SEGDES,MCOORD IF(MROTA1.NE.0) SEGDES MROTA1 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 segact mcoord if(.false.) then call quenom(icha) write(6,*) 'FORM nouvelle configuration', mcoord,mrota,icha call trbac endif END