Télécharger la plaquette Cast3M


fr en

Télécharger form.eso

Retour à la liste

Numérotation des lignes : 

form

  1. C FORM      SOURCE    MB234859  25/02/27    21:15:04     12111          
  2.  
  3. C=======================================================================
  4. C=                             F O R M                                 =
  5. C=                             -------                                 =
  6. C=                                                                     =
  7. C=  FONCTEUR CAST3M 'FORME' DE MISE A JOUR DE CONFIGURATIONS :         =
  8. C=  ----------------------------------------------------------         =
  9. C=   (CONF2) (CAR2)  =  'FORME'  (CONF1)  (CHPO1)  (MODL1  CAR1) ;     =
  10. C=                                                                     =
  11. C= UTILISATION : SANS OPERANDE MET DANS LA PILE LE SEGMENT MCOORD
  12. C=             : AVEC UN OBJET CONFIGURA, ACTIVE CETTE CONFIGURATION
  13. C=             : AVEC UN CHAMPOINT, CREE LES COORD = COURANTES+DEFORMEE
  14. C=               PUIS ACTIVE CETTE CONFIG
  15. C=             : AVEC CHPOINT ET CONFIGUR  CREE ET ACTIVE LA CONFIGU =
  16. C=                    CONFIGUR + DEFORMEE ISSU DE CHPOINT.
  17. C= SERT A NOMMER, ACTIVER OU CREER UNE CONFIGURATION C'EST-A-DIRE UN
  18. C= CHAMP DE COORDONNEES SUPPORT.
  19. C=                                                                     =
  20. C=  ARGUMENTS :                                                        =
  21. C=  -----------                                                        =
  22. C=   CONF1   (CONFIGU)  Champ de coordonnees support (configuration)   =
  23. C=   CHPO1   (CHPOINT)  Champ de deplacements sur la structure         =
  24. C=   MODL1   (MMODEL)   Modele de la structure etudiee    (facultatif) =
  25. C=   CAR1    (MCHAML)   Caracteristiques geometriques     (facultatif) =
  26. C=                      Sous-type 'CARACTERISTIQUES'                   =
  27. C=                                                                     =
  28. C=  RESULTATS :                                                        =
  29. C=  -----------                                                        =
  30. C=   CONF2   (CONFIGU)  Champ de coordonnees support actualise         =
  31. C=   CAR2    (MCHAML)   Caracteristiques geometriques actualisees      =
  32. C=======================================================================
  33.  
  34.       SUBROUTINE FORM
  35.  
  36.       IMPLICIT INTEGER(I-N)
  37.       IMPLICIT REAL*8 (A-H,O-Z)
  38.  
  39.  
  40. -INC PPARAM
  41. -INC CCOPTIO
  42. -INC CCASSIS
  43.  
  44. -INC SMCOORD
  45.       POINTEUR MXCA.MCOORD
  46. -INC SMELEME
  47. -INC SMCHPOI
  48.       character*16 icha
  49.       LOGICAL BUR,ROT
  50.       CHARACTER*(LOCOMP) MDDL
  51.       CHARACTER*(LOCOMP) NODEF(3),NODEG(3)
  52.       CHARACTER*(LOCOMP) RODEF(3),RODEG(3)
  53.  
  54.       DATA NODEF / 'UX  ','UY  ','UZ  ' /
  55.       DATA NODEG / 'UR  ','UZ  ','UT  ' /
  56.       DATA RODEF / 'RX  ','RY  ','RZ  ' /
  57.       DATA RODEG / 'RR  ','RZ  ','RT  ' /
  58.  
  59. C *   attention aux assistants ....
  60.       if (NBESC.NE.0) then
  61.           if (iimpi .eq. 1234)
  62.  
  63.      &  write(ioimp,*) ' il faut bloquer les assistants'
  64.       ith=0
  65.       ith=oothrd
  66.       if(ith.ne.0) then
  67.           call erreur (1010)
  68.           return
  69.       endif
  70.        do ith=1,nbesc
  71.           mesins= mescl(ith)
  72.           segact mesins
  73.   20      if(nbins.ne.0) then
  74. *         write(6,*)'on attend la fin des esclaves ith nbins',ith,nbins
  75.              segdes mesins*record
  76.              segact mesins*(mod,ecr=1)
  77.              go to 20
  78.           endif
  79.           segdes mesins*record
  80.         enddo
  81.         mestra=imestr
  82.         SEGACT MESTRA*MOD
  83.         if (iimpi .eq. 1234)
  84.      &    write(ioimp,*) ' assistants en attente'
  85.       end if
  86.  
  87.       SEGACT,MCOORD
  88. c*      NBPTX=XCOOR(/1)/idimp1
  89. c*      NBPTX=NBPTS
  90.  
  91.       MCOO   = 0
  92.       IPTC   = 0
  93.       IPMODL = 0
  94.  
  95.       CALL LIROBJ('CONFIGUR',MCOO,0,IRET)
  96.       CALL LIROBJ('CHPOINT ',IPTC,0,IRET)
  97.       CALL LIROBJ('MMODEL  ',IPMODL,0,IRET)
  98.       IF (IERR.NE.0) GOTO 10
  99. **    write(6,*) 'form mcoo iptc ipmodl',mcoo,iptc,ipmodl
  100.  
  101.  
  102.       IF (MCOO.EQ.0.AND.IPTC.EQ.0) THEN                  
  103. *  il faut rendre la configuration courante
  104.         segact mcoord
  105.         mrotat=mrota
  106.         CALL ECROBJ('CONFIGUR',MCOORD)
  107.         goto 10 
  108.       ENDIF
  109.  
  110.       IF (IPTC .NE. 0) THEN
  111.         CALL ACTOBJ('CHPOINT ',IPTC,1)
  112.       ENDIF
  113.  
  114. C= Cas d'un MCHAML de CARACTERISTIQUES a TRANSPORTER
  115.       IF (IPMODL .NE. 0) THEN
  116.         IF (IPTC.EQ.0) THEN
  117.           MOTERR(1:8)='CHPOINT'
  118.           CALL ERREUR(37)
  119.           RETURN
  120.         ENDIF
  121.         CALL LIROBJ('MCHAML  ',IPIN,1,IRET)
  122.         IF (IERR .NE. 0) GOTO 10
  123.  
  124.         CALL ACTOBJ('MMODEL  ',IPMODL,1)
  125.         CALL ACTOBJ('MCHAML  ',IPIN  ,1)
  126.  
  127.         CALL REDUAF(IPIN,IPMODL,IPCH1,0,IR,KER)
  128.         IF (IR   .NE. 1) CALL ERREUR(KER)
  129.         IF (IERR .NE. 0) GOTO 10
  130.  
  131. C       Mise a jour des caracteristiques materielles
  132.         CALL FORMCH(IPMODL,IPCH1,IPTC,IRET,IPCH2,MCOORD)
  133.         IF (IRET.EQ.0.OR.IERR.NE.0) GOTO 10
  134.         CALL ECROBJ('MCHAML  ',IPCH2)
  135.         IF (IERR .NE. 0) GOTO 10
  136. c-dbg        call zpchel(ipch1,0)
  137. c-dbg        call zpchel(ipch2,0)
  138.       ENDIF
  139.  
  140.       idimp1=IDIM+1
  141.       IF (IPTC.EQ.0) THEN
  142.         IF (MCOO.EQ.0) THEN
  143.           SEGINI,MXCA=MCOORD
  144.           CALL ECROBJ('CONFIGUR',MXCA)
  145.         ELSE
  146.           IF(MXCA.NE.MCOORD) THEN
  147.           MXCA=MCOO
  148.           SEGACT,MXCA
  149.           NBPTA=MXCA.XCOOR(/1)/idimp1
  150.           IF (NBPTA.NE.NBPTX) THEN
  151. c*            NBPTS=NBPTX
  152.             SEGADJ,MXCA
  153.             DO i=NBPTA*idimp1+1,NBPTS*idimp1
  154.               MXCA.XCOOR(i)=XCOOR(i)
  155.             ENDDO
  156.           ENDIF
  157.           MCOORD=MXCA
  158.           ENDIF
  159.         ENDIF
  160.       IF (IPMODL .NE. 0) THEN
  161.         mclcnf=mcoord
  162.         CALL ACTOBJ('MCHAML  ',IPCH2,1)
  163.       ENDIF
  164.       ELSE
  165. C  Mise a jour des coordonnes en ajoutant le champ de deplacement
  166.         IF (MCOO.NE.0) THEN
  167.           MXCA=MCOO
  168.           SEGACT,MXCA
  169.           NBPTA=MXCA.XCOOR(/1)/idimp1
  170.           IF (NBPTA.NE.NBPTX) THEN
  171. c*            NBPTS=NBPTX
  172.             SEGADJ,MXCA
  173.             DO i=NBPTA*idimp1+1,NBPTS*idimp1
  174.               MXCA.XCOOR(i)=XCOOR(i)
  175.             ENDDO
  176.           ENDIF
  177.           MCOORD=MXCA
  178.         ENDIF
  179.  
  180.         bur=((ifour.eq.0).or.(ifour.eq.1))
  181.         ncmax=3
  182. **      write(6,*) 'FORM ifomod ifour',ifomod,ifour
  183.  
  184.         ROT=.FALSE.
  185.         MCHPOI=IPTC
  186. **      call ecchpo(mchpoi,1)
  187.         DO iSoup=1,IPCHP(/1)
  188.           MSOUPO=IPCHP(iSoup)
  189.           MPOVAL=IPOVAL
  190.           DO IC=1,NOCOMP(/2)
  191.             MDDL=NOCOMP(IC)
  192.             DO INUM=1,3
  193.               IF (BUR) THEN
  194.                 IF (RODEG(INUM).EQ.MDDL) ROT=.TRUE.
  195.               ELSE
  196.                 IF (RODEF(INUM).EQ.MDDL) ROT=.TRUE.
  197.               ENDIF
  198.             ENDDO
  199.           ENDDO            
  200.         ENDDO            
  201. **      write(6,*) 'form bur rot',bur,rot,ncmax,ifomod,ifour
  202.  
  203.         SEGINI,MXCA=MCOORD
  204. *  definition eventuelle des rotations
  205.         MROTA1=0
  206.         MROTAT=0
  207.         IF(ROT) THEN
  208.           IF (MROTA.NE.0) THEN 
  209.             MROTAT=MROTA
  210.             SEGINI,MROTA1=MROTAT
  211.           ELSE
  212.             idimr=3
  213.             SEGINI,MROTA1
  214. **          write(6,*) 'mrota1',mrota1
  215.           ENDIF
  216.           MXCA.MROTA=MROTA1
  217.         ENDIF
  218.         DO iSoup=1,IPCHP(/1)
  219.           MSOUPO=IPCHP(iSoup)
  220.           MPOVAL=IPOVAL
  221.           IPT2=IGEOC
  222.           NbElt=IPT2.NUM(/2)
  223.           DO IC=1,NOCOMP(/2)
  224.             MDDL=NOCOMP(IC)
  225.             DO INUM=1,NCMAX
  226.               IF (BUR) THEN
  227.                 IF (NODEG(INUM).EQ.MDDL) GOTO 81
  228.               ELSE
  229.                 IF (NODEF(INUM).EQ.MDDL) GOTO 81
  230.               ENDIF
  231.             ENDDO
  232.             GOTO 70
  233.  81         DO iElt=1,NbElt
  234.               IP=(IPT2.NUM(1,iElt)-1)*idimp1+INUM
  235.               MXCA.XCOOR(IP)=MXCA.XCOOR(IP)+VPOCHA(iElt,IC)
  236.             ENDDO
  237.  70         CONTINUE
  238.             IF(ROT) THEN
  239.             DO INUM=1,3
  240.               IF (BUR) THEN
  241.                 IF (RODEG(INUM).EQ.MDDL) GOTO 82
  242.               ELSE
  243.                 IF (RODEF(INUM).EQ.MDDL) GOTO 82
  244.               ENDIF
  245.             ENDDO
  246.             GOTO 71
  247.  82         DO iElt=1,NbElt
  248.               IP=IPT2.NUM(1,iElt)              
  249.               MROTA1.XROTA(inum,ip)=MROTA1.XROTA(inum,IP)+
  250.      >                              VPOCHA(iElt,IC)
  251.             ENDDO
  252.  71         CONTINUE
  253.             ENDIF               
  254.           ENDDO
  255.         ENDDO
  256.         IF(MROTA.NE.0) SEGDES MROTA
  257.         SEGDES MCOORD
  258.         MCOORD=MXCA
  259.         SEGDES,MCOORD                  
  260.         IF(MROTA1.NE.0) SEGDES MROTA1
  261.         CALL ECROBJ('CONFIGUR',MCOORD)
  262.       ENDIF
  263.  
  264.  10   CONTINUE
  265. C *   attention aux assistants ....
  266.       if (NBESC.NE.0) then
  267. C *     il faut liberer le segment de dialogue
  268.         mestra=imestr
  269.         SEGDES MESTRA
  270.       end if
  271.  
  272. c      return
  273.       segact mcoord
  274.       if(.false.) then
  275.        call quenom(icha)
  276.        write(6,*) 'FORM nouvelle configuration', mcoord,mrota,icha
  277.        call trbac
  278.       endif
  279.       END
  280.  
  281.  
  282.  
  283.  
  284.  
  285.  
  286.  
  287.  
  288.  
  289.  
  290.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales