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/01/16    21:15:03     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.  
  100.       IF (IPTC .NE. 0) THEN
  101.         CALL ACTOBJ('CHPOINT ',IPTC,1)
  102.       ENDIF
  103.  
  104. C= Cas d'un MCHAML de CARACTERISTIQUES a TRANSPORTER
  105.       IF (IPMODL .NE. 0) THEN
  106.         IF (IPTC.EQ.0) THEN
  107.           MOTERR(1:8)='CHPOINT'
  108.           CALL ERREUR(37)
  109.           RETURN
  110.         ENDIF
  111.         CALL LIROBJ('MCHAML  ',IPIN,1,IRET)
  112.         IF (IERR .NE. 0) GOTO 10
  113.  
  114.         CALL ACTOBJ('MMODEL  ',IPMODL,1)
  115.         CALL ACTOBJ('MCHAML  ',IPIN  ,1)
  116.  
  117.         CALL REDUAF(IPIN,IPMODL,IPCH1,0,IR,KER)
  118.         IF (IR   .NE. 1) CALL ERREUR(KER)
  119.         IF (IERR .NE. 0) GOTO 10
  120.  
  121. C       Mise a jour des caracteristiques materielles
  122.         CALL FORMCH(IPMODL,IPCH1,IPTC,IRET,IPCH2)
  123.         IF (IRET.EQ.0.OR.IERR.NE.0) GOTO 10
  124.         CALL ECROBJ('MCHAML  ',IPCH2)
  125.         IF (IERR .NE. 0) GOTO 10
  126. c-dbg        call zpchel(ipch1,0)
  127. c-dbg        call zpchel(ipch2,0)
  128.       ENDIF
  129.  
  130.       idimp1=IDIM+1
  131.       IF (IPTC.EQ.0) THEN
  132.         IF (MCOO.EQ.0) THEN
  133.           SEGINI,MXCA=MCOORD
  134.           CALL ECROBJ('CONFIGUR',MXCA)
  135.         ELSE
  136.           IF(MXCA.NE.MCOORD) THEN
  137.           MXCA=MCOO
  138.           SEGACT,MXCA
  139.           NBPTA=MXCA.XCOOR(/1)/idimp1
  140.           IF (NBPTA.NE.NBPTX) THEN
  141. c*            NBPTS=NBPTX
  142.             SEGADJ,MXCA
  143.             DO i=NBPTA*idimp1+1,NBPTS*idimp1
  144.               MXCA.XCOOR(i)=XCOOR(i)
  145.             ENDDO
  146.           ENDIF
  147.           MCOORD=MXCA
  148.           ENDIF
  149.         ENDIF
  150.       IF (IPMODL .NE. 0) THEN
  151.         mclcnf=mcoord
  152.         CALL ACTOBJ('MCHAML  ',IPCH2,1)
  153.       ENDIF
  154.       ELSE
  155. C  Mise a jour des coordonnes en ajoutant le champ de deplacement
  156.         IF (MCOO.NE.0) THEN
  157.           MXCA=MCOO
  158.           SEGACT,MXCA
  159.           NBPTA=MXCA.XCOOR(/1)/idimp1
  160.           IF (NBPTA.NE.NBPTX) THEN
  161. c*            NBPTS=NBPTX
  162.             SEGADJ,MXCA
  163.             DO i=NBPTA*idimp1+1,NBPTS*idimp1
  164.               MXCA.XCOOR(i)=XCOOR(i)
  165.             ENDDO
  166.           ENDIF
  167.           MCOORD=MXCA
  168.         ENDIF
  169.  
  170.         IF (IFOMOD.EQ.0.OR.IFOMOD.EQ.1) THEN
  171.           BUR=.TRUE.
  172.           NCMAX=2
  173.         ELSE IF (IFOMOD.EQ.4.OR.IFOMOD.EQ.5) THEN
  174.           BUR=.TRUE.
  175.           NCMAX=1
  176.         ELSE IF (IFOMOD.EQ.-1) THEN
  177.           BUR=.FALSE.
  178.           NCMAX=2
  179.         ELSE IF (IFOMOD.EQ.3) THEN
  180.           BUR=.FALSE.
  181.           NCMAX=1
  182.         ELSE
  183.           BUR=.FALSE.
  184.           NCMAX=3
  185.         ENDIF
  186.  
  187.         ROT=.FALSE.
  188.         MCHPOI=IPTC
  189.         DO iSoup=1,IPCHP(/1)
  190.           MSOUPO=IPCHP(iSoup)
  191.           MPOVAL=IPOVAL
  192.           DO IC=1,NOCOMP(/2)
  193.             MDDL=NOCOMP(IC)
  194.             DO INUM=1,NCMAX
  195.               IF (BUR) THEN
  196.                 IF (RODEG(INUM).EQ.MDDL) ROT=.TRUE.
  197.               ELSE
  198.                 IF (RODEF(INUM).EQ.MDDL) ROT=.TRUE.
  199.               ENDIF
  200.             ENDDO
  201.           ENDDO            
  202.         ENDDO            
  203.  
  204.         SEGINI,MXCA=MCOORD
  205. *  definition eventuelle des rotations
  206.         MROTA1=0
  207.         IF(ROT) THEN
  208.           IF (MROTA.NE.0) THEN 
  209.             SEGINI,MROTA1=MROTA
  210.           ELSE
  211.             SEGINI MROTA1
  212.           ENDIF
  213.           MXCA.MROTA=MROTA1
  214.         ENDIF
  215.         DO iSoup=1,IPCHP(/1)
  216.           MSOUPO=IPCHP(iSoup)
  217.           MPOVAL=IPOVAL
  218.           IPT2=IGEOC
  219.           NbElt=IPT2.NUM(/2)
  220.           DO IC=1,NOCOMP(/2)
  221.             MDDL=NOCOMP(IC)
  222.             DO INUM=1,NCMAX
  223.               IF (BUR) THEN
  224.                 IF (NODEG(INUM).EQ.MDDL) GOTO 81
  225.               ELSE
  226.                 IF (NODEF(INUM).EQ.MDDL) GOTO 81
  227.               ENDIF
  228.             ENDDO
  229.             GOTO 70
  230.  81         DO iElt=1,NbElt
  231.               IP=(IPT2.NUM(1,iElt)-1)*idimp1+INUM
  232.               MXCA.XCOOR(IP)=MXCA.XCOOR(IP)+VPOCHA(iElt,IC)
  233.             ENDDO
  234.  70         CONTINUE
  235.             IF(ROT) THEN
  236.             DO INUM=1,NCMAX
  237.               IF (BUR) THEN
  238.                 IF (RODEG(INUM).EQ.MDDL) GOTO 82
  239.               ELSE
  240.                 IF (RODEF(INUM).EQ.MDDL) GOTO 82
  241.               ENDIF
  242.             ENDDO
  243.             GOTO 71
  244.  82         DO iElt=1,NbElt
  245.               IP=(IPT2.NUM(1,iElt)-1)*idim+INUM
  246.               MROTA1.XROTA(IP)=MROTA1.XROTA(IP)+VPOCHA(iElt,IC)
  247.             ENDDO
  248.  71         CONTINUE
  249.             ENDIF               
  250.           ENDDO
  251.         ENDDO
  252.         SEGDES MCOORD
  253.         IF(MROTA.NE.0) SEGDES MROTA
  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. **    call quenom(icha)
  270. **    write(6,*) 'FORM nouvelle configuration', mcoord,icha
  271.  
  272.       END
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  

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