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/24    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)
  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. **      IF (IFOMOD.EQ.0.OR.IFOMOD.EQ.1) THEN
  181. **        BUR=.TRUE.
  182. **        NCMAX=2
  183. **      ELSE IF (IFOMOD.EQ.4.OR.IFOMOD.EQ.5) THEN
  184. **        BUR=.TRUE.
  185. **        NCMAX=1
  186. **      ELSE IF (IFOMOD.EQ.-1) THEN
  187. **        BUR=.FALSE.
  188. **        NCMAX=2
  189. **      ELSE IF (IFOMOD.EQ.3) THEN
  190. **        BUR=.FALSE.
  191. **        NCMAX=1
  192. **      ELSE
  193. **        BUR=.FALSE.
  194. **        NCMAX=3
  195. **      ENDIF
  196.         bur=.false.
  197.         if (ifour.eq.2) then
  198.          bur=.false.
  199.          ncmax=3
  200.          nrb=4
  201.          nrh=6
  202.         elseif (ifour.lt.0) then
  203.          bur=.false.
  204.          ncmax=2
  205.          nrb=6
  206.          nrh=6
  207.         elseif (ifour.eq.0) then
  208.          bur=.true.
  209.          ncmax=2
  210.          nrb=6
  211.          nrh=6
  212.         elseif (ifour.eq.1) then
  213.          bur=.true.
  214.          ncmax=3
  215.          nrb=6
  216.          nrh=6
  217.         elseif (ifour.eq.3) then
  218.          bur=.false.
  219.          ncmax=1
  220.          nrb=4
  221.          nrh=3
  222.         endif
  223. **      write(6,*) 'FORM ifomod ifour',ifomod,ifour
  224.  
  225.  
  226.         ROT=.FALSE.
  227.         MCHPOI=IPTC
  228. **      call ecchpo(mchpoi,1)
  229.         DO iSoup=1,IPCHP(/1)
  230.           MSOUPO=IPCHP(iSoup)
  231.           MPOVAL=IPOVAL
  232.           DO IC=1,NOCOMP(/2)
  233.             MDDL=NOCOMP(IC)
  234.             DO INUM=nrb,nrh    
  235.               IF (BUR) THEN
  236.                 IF (RODEG(INUM).EQ.MDDL) ROT=.TRUE.
  237.               ELSE
  238.                 IF (RODEF(INUM).EQ.MDDL) ROT=.TRUE.
  239.               ENDIF
  240.             ENDDO
  241.           ENDDO            
  242.         ENDDO            
  243. **      write(6,*) 'form bur rot',bur,rot,ncmax,ifomod,ifour
  244.  
  245.         SEGINI,MXCA=MCOORD
  246. *  definition eventuelle des rotations
  247.         MROTA1=0
  248.         MROTAT=0
  249.         IF(ROT) THEN
  250.           IF (MROTA.NE.0) THEN 
  251.             MROTAT=MROTA
  252.             SEGINI,MROTA1=MROTAT
  253.           ELSE
  254.             if (ifour.eq.2) then    
  255.              idimr=3
  256.             elseif (ifour.le.1) then    
  257.              idimr=1
  258.             endif
  259.             SEGINI,MROTA1
  260. **          write(6,*) 'mrota1',mrota1
  261.           ENDIF
  262.           MXCA.MROTA=MROTA1
  263.         ENDIF
  264.         DO iSoup=1,IPCHP(/1)
  265.           MSOUPO=IPCHP(iSoup)
  266.           MPOVAL=IPOVAL
  267.           IPT2=IGEOC
  268.           NbElt=IPT2.NUM(/2)
  269.           DO IC=1,NOCOMP(/2)
  270.             MDDL=NOCOMP(IC)
  271.             DO INUM=1,NCMAX
  272.               IF (BUR) THEN
  273.                 IF (NODEG(INUM).EQ.MDDL) GOTO 81
  274.               ELSE
  275.                 IF (NODEF(INUM).EQ.MDDL) GOTO 81
  276.               ENDIF
  277.             ENDDO
  278.             GOTO 70
  279.  81         DO iElt=1,NbElt
  280.               IP=(IPT2.NUM(1,iElt)-1)*idimp1+INUM
  281.               MXCA.XCOOR(IP)=MXCA.XCOOR(IP)+VPOCHA(iElt,IC)
  282.             ENDDO
  283.  70         CONTINUE
  284.             IF(ROT) THEN
  285.             DO INUM=nrb,nrh
  286.               IF (BUR) THEN
  287.                 IF (RODEG(INUM).EQ.MDDL) GOTO 82
  288.               ELSE
  289.                 IF (RODEF(INUM).EQ.MDDL) GOTO 82
  290.               ENDIF
  291.             ENDDO
  292.             GOTO 71
  293.  82         DO iElt=1,NbElt
  294.               IP=IPT2.NUM(1,iElt)              
  295.               MROTA1.XROTA(inum,ip)=MROTA1.XROTA(inum,IP)+
  296.      >              VPOCHA(iElt,IC)
  297.             ENDDO
  298.  71         CONTINUE
  299.             ENDIF               
  300.           ENDDO
  301.         ENDDO
  302.         IF(MROTA.NE.0) SEGDES MROTA
  303.         SEGDES MCOORD
  304.         MCOORD=MXCA
  305.         SEGDES,MCOORD                  
  306.         IF(MROTA1.NE.0) SEGDES MROTA1
  307.         CALL ECROBJ('CONFIGUR',MCOORD)
  308.       ENDIF
  309.  
  310.  10   CONTINUE
  311. C *   attention aux assistants ....
  312.       if (NBESC.NE.0) then
  313. C *     il faut liberer le segment de dialogue
  314.         mestra=imestr
  315.         SEGDES MESTRA
  316.       end if
  317.  
  318. c      return
  319.       segact mcoord
  320.       if(.false.) then
  321.        call quenom(icha)
  322.        write(6,*) 'FORM nouvelle configuration', mcoord,mrota,icha
  323.        call trbac
  324.       endif
  325.       END
  326.  
  327.  
  328.  
  329.  
  330.  
  331.  
  332.  
  333.  
  334.  
  335.  

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