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    PV090527  25/06/11    21:15:08     12279          
  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.  
  89.       MCOO   = 0
  90.       IPTC   = 0
  91.       IPMODL = 0
  92.  
  93.       CALL LIROBJ('CONFIGUR',MCOO,0,IRET)
  94.       CALL LIROBJ('CHPOINT ',IPTC,0,IRET)
  95.       CALL LIROBJ('MMODEL  ',IPMODL,0,IRET)
  96.       IF (IERR.NE.0) GOTO 10
  97. **    write(6,*) 'form mcoo iptc ipmodl',mcoo,iptc,ipmodl
  98.  
  99.  
  100.       IF (MCOO.EQ.0.AND.IPTC.EQ.0) THEN                  
  101. *  il faut rendre la configuration courante
  102.         segact mcoord
  103.         mrotat=mrota
  104.         CALL ECROBJ('CONFIGUR',MCOORD)
  105.         goto 10 
  106.       ENDIF
  107.  
  108.       IF (IPTC .NE. 0) THEN
  109.         CALL ACTOBJ('CHPOINT ',IPTC,1)
  110.       ENDIF
  111.  
  112. C= Cas d'un MCHAML de CARACTERISTIQUES a TRANSPORTER
  113.       IF (IPMODL .NE. 0) THEN
  114.         IF (IPTC.EQ.0) THEN
  115.           MOTERR(1:8)='CHPOINT'
  116.           CALL ERREUR(37)
  117.           RETURN
  118.         ENDIF
  119.         CALL LIROBJ('MCHAML  ',IPIN,1,IRET)
  120.         IF (IERR .NE. 0) GOTO 10
  121.  
  122.         CALL ACTOBJ('MMODEL  ',IPMODL,1)
  123.         CALL ACTOBJ('MCHAML  ',IPIN  ,1)
  124.  
  125.         CALL REDUAF(IPIN,IPMODL,IPCH1,0,IR,KER)
  126.         IF (IR   .NE. 1) CALL ERREUR(KER)
  127.         IF (IERR .NE. 0) GOTO 10
  128.  
  129. C       Mise a jour des caracteristiques materielles
  130.         CALL FORMCH(IPMODL,IPCH1,IPTC,IRET,IPCH2,MCOORD)
  131.         IF (IRET.EQ.0.OR.IERR.NE.0) GOTO 10
  132.         CALL ECROBJ('MCHAML  ',IPCH2)
  133.         IF (IERR .NE. 0) GOTO 10
  134. c-dbg        call zpchel(ipch1,0)
  135. c-dbg        call zpchel(ipch2,0)
  136.       ENDIF
  137.  
  138.       idimp1=IDIM+1
  139.       IF (IPTC.EQ.0) THEN
  140.         IF (MCOO.EQ.0) THEN
  141.           SEGINI,MXCA=MCOORD
  142.           CALL ECROBJ('CONFIGUR',MXCA)
  143.         ELSE
  144.           IF(MXCA.NE.MCOORD) THEN
  145.           MXCA=MCOO
  146.           SEGACT,MXCA
  147.           NBPTA=MXCA.XCOOR(/1)/idimp1
  148.           IF (NBPTA.NE.NBPTS) THEN
  149.             SEGADJ,MXCA
  150.             DO i=NBPTA*idimp1+1,NBPTS*idimp1
  151.               MXCA.XCOOR(i)=XCOOR(i)
  152.             ENDDO
  153.           ENDIF
  154.           MCOORD=MXCA
  155.           ENDIF
  156.         ENDIF
  157.       IF (IPMODL .NE. 0) THEN
  158.         mclcnf=mcoord
  159.         CALL ACTOBJ('MCHAML  ',IPCH2,1)
  160.       ENDIF
  161.       ELSE
  162. C  Mise a jour des coordonnes en ajoutant le champ de deplacement
  163.         IF (MCOO.NE.0) THEN
  164.           MXCA=MCOO
  165.           SEGACT,MXCA
  166.           NBPTA=MXCA.XCOOR(/1)/idimp1
  167.           IF (NBPTA.NE.NBPTS) THEN
  168.             SEGADJ,MXCA
  169.             DO i=NBPTA*idimp1+1,NBPTS*idimp1
  170.               MXCA.XCOOR(i)=XCOOR(i)
  171.             ENDDO
  172.           ENDIF
  173.           MCOORD=MXCA
  174.         ENDIF
  175.  
  176.         bur=((ifour.eq.0).or.(ifour.eq.1))
  177.         ncmax=3
  178. **      write(6,*) 'FORM ifomod ifour',ifomod,ifour
  179.  
  180.         ROT=.FALSE.
  181.         MCHPOI=IPTC
  182. **      call ecchpo(mchpoi,1)
  183.         DO iSoup=1,IPCHP(/1)
  184.           MSOUPO=IPCHP(iSoup)
  185.           MPOVAL=IPOVAL
  186.           DO IC=1,NOCOMP(/2)
  187.             MDDL=NOCOMP(IC)
  188.             DO INUM=1,3
  189.               IF (BUR) THEN
  190.                 IF (RODEG(INUM).EQ.MDDL) ROT=.TRUE.
  191.               ELSE
  192.                 IF (RODEF(INUM).EQ.MDDL) ROT=.TRUE.
  193.               ENDIF
  194.             ENDDO
  195.           ENDDO            
  196.         ENDDO            
  197. **      write(6,*) 'form bur rot',bur,rot,ncmax,ifomod,ifour
  198.  
  199.         SEGINI,MXCA=MCOORD
  200. *  definition eventuelle des rotations
  201.         MROTA1=0
  202.         MROTAT=0
  203.         IF(ROT) THEN
  204.           IF (MROTA.NE.0) THEN 
  205.             MROTAT=MROTA
  206.             SEGINI,MROTA1=MROTAT
  207.           ELSE
  208.             idimr=3
  209.             SEGINI,MROTA1
  210. **          write(6,*) 'mrota1',mrota1
  211.           ENDIF
  212.           MXCA.MROTA=MROTA1
  213.         ENDIF
  214.         DO iSoup=1,IPCHP(/1)
  215.           MSOUPO=IPCHP(iSoup)
  216.           MPOVAL=IPOVAL
  217.           IPT2=IGEOC
  218.           NbElt=IPT2.NUM(/2)
  219.           DO IC=1,NOCOMP(/2)
  220.             MDDL=NOCOMP(IC)
  221.             DO INUM=1,NCMAX
  222.               IF (BUR) THEN
  223.                 IF (NODEG(INUM).EQ.MDDL) GOTO 81
  224.               ELSE
  225.                 IF (NODEF(INUM).EQ.MDDL) GOTO 81
  226.               ENDIF
  227.             ENDDO
  228.             GOTO 70
  229.  81         DO iElt=1,NbElt
  230.               IP=(IPT2.NUM(1,iElt)-1)*idimp1+INUM
  231.               MXCA.XCOOR(IP)=MXCA.XCOOR(IP)+VPOCHA(iElt,IC)
  232.             ENDDO
  233.  70         CONTINUE
  234.             IF(ROT) THEN
  235.             DO INUM=1,3
  236.               IF (BUR) THEN
  237.                 IF (RODEG(INUM).EQ.MDDL) GOTO 82
  238.               ELSE
  239.                 IF (RODEF(INUM).EQ.MDDL) GOTO 82
  240.               ENDIF
  241.             ENDDO
  242.             GOTO 71
  243.  82         DO iElt=1,NbElt
  244.               IP=IPT2.NUM(1,iElt)              
  245.               MROTA1.XROTA(inum,ip)=MROTA1.XROTA(inum,IP)+
  246.      >                              VPOCHA(iElt,IC)
  247.             ENDDO
  248.  71         CONTINUE
  249.             ENDIF               
  250.           ENDDO
  251.         ENDDO
  252.         IF(MROTA.NE.0) SEGDES MROTA
  253.         SEGDES MCOORD
  254.         MCOORD=MXCA
  255.         SEGDES,MCOORD                  
  256.         IF(MROTA1.NE.0) SEGDES MROTA1
  257.         CALL ECROBJ('CONFIGUR',MCOORD)
  258.       ENDIF
  259.  
  260.  10   CONTINUE
  261. C *   attention aux assistants ....
  262.       if (NBESC.NE.0) then
  263. C *     il faut liberer le segment de dialogue
  264.         mestra=imestr
  265.         SEGDES MESTRA
  266.       end if
  267.  
  268. c      return
  269.       segact mcoord
  270.       if(.false.) then
  271.        call quenom(icha)
  272.        write(6,*) 'FORM nouvelle configuration', mcoord,mrota,icha
  273.        call trbac
  274.       endif
  275.       END
  276.  
  277.  
  278.  
  279.  
  280.  
  281.  
  282.  
  283.  
  284.  
  285.  
  286.  
  287.  

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