Télécharger la plaquette Cast3M


fr en

Télécharger dtsolu.eso

Retour à la liste

Numérotation des lignes : 

dtsolu

  1. C DTSOLU    SOURCE    PV        21/01/21    21:15:12     10862          
  2.  
  3.       SUBROUTINE DTSOLU(IRET)
  4.  
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8.       character*19 mrota , mrotp
  9.       character*24 mrots
  10.       character*22 mtran , mtrap
  11.       character*27 mtras
  12.       character*1  ichari,mrotd,mtrad,icharr
  13.       logical logii,logir
  14.       integer ico, icoch, icolr, icotb
  15.       integer ipile, iret, irett, irret
  16.       integer irotd, irotp, irots
  17.       integer itabr, itrad, itrap, itras
  18.       integer itys, ivali, ivalr, kmel1, ksolit
  19.       integer n, nip, nipo, nn
  20.       real*8 xvali, xvalr
  21. C
  22. C  =====================================================================
  23. C  =  DESTRUCTION D'UN OBJET SOLUTION                                  =
  24. C  =                                                                   =
  25. C  =  CREATION    06/01/86                                             =
  26. C  =  PROGRAMMEUR GUILBAUD                                             =
  27. C  =====================================================================
  28. C
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC COCOLL
  33. -INC SMSOLUT
  34. -INC SMELEME
  35. -INC SMTABLE
  36. -INC SMLREEL
  37. -INC TMCOLAC
  38.  
  39.       pointeur piles.LISPIL
  40.       pointeur jcolac.ICOLAC
  41.       pointeur jlisse.ILISSE
  42.       pointeur jtlacc.ITLACC
  43.       pointeur pile.ITLACC
  44. *
  45.       DATA MROTA/'ROTATION D ENSEMBLE'/
  46.       DATA MROTP/'VITESSE DE ROTATION'/
  47.       DATA MROTS/'ACCELERATION DE ROTATION'/
  48.       DATA MTRAN/'TRANSLATION D ENSEMBLE'/
  49.       DATA MTRAP/'VITESSE DE TRANSLATION'/
  50.       DATA MTRAS/'ACCELERATION DE TRANSLATION'/
  51. *
  52.       iun=1
  53.       MSOLUT=IRET
  54.       irret=0
  55.       SEGACT MSOLUT
  56.       ITYS=0
  57.       IF(ITYSOL.NE.'MODE    ') GO TO 101
  58.       ITYS=1
  59.       GO TO 200
  60.  101  CONTINUE
  61.       IF(ITYSOL.NE.'SOLUSTAT'.AND.ITYSOL.NE.'PSEUMODE') GO TO 102
  62.       ITYS=2
  63.       GOTO 200
  64.  102  CONTINUE
  65.       IF(ITYSOL.NE.'DYNAMIQU') GOTO 103
  66.       ITYS=3
  67.       GO TO 200
  68.  103  MOTERR(1:8)='SOLUTION'
  69.       MOTERR(9:16)=ITYSOL
  70.       CALL ERREUR(66)
  71. C     L OPERATEUR DETRUIRE NE FONCTIONNE PAS POUR UN OBJET SOLUTION
  72. C     COMPORTANT CE SOUS-TYPE
  73.       SEGDES MSOLUT
  74.       GOTO 1000
  75.   200 NIPO=MSOLIS(/1)
  76.       MSOLRE=MSOLIS(1)
  77.       IF(MSOLRE.NE.0) SEGSUP MSOLRE
  78.       MSOLEN=MSOLIS(2)
  79.       IF(MSOLEN.NE.0) SEGSUP MSOLEN
  80.       MELEME=MSOLIS(3)
  81.       IF(MELEME.NE.0.AND.ITYS.EQ.1) THEN
  82.          SEGSUP MELEME
  83.          IF(IPSAUV.NE.0) THEN
  84.          ICOLAC = IPSAUV
  85.          SEGACT ICOLAC
  86.          ILISSE=ILISSG
  87.          SEGACT ILISSE*MOD
  88.          CALL TYPFIL('MAILLAGE',ICO)
  89.          ITLACC = KCOLA(ICO)
  90.          SEGACT ITLACC*MOD
  91.          CALL AJOUN0(ITLACC,MELEME,ILISSE,iun)
  92.          SEGDES ITLACC,ILISSE
  93.          SEGDES ICOLAC
  94.          ENDIF
  95. C        Suppression du meleme des piles d'objets communiques
  96.          if(piComm.gt.0) then
  97.             piles=piComm
  98.             segact piles
  99.             call typfil('MAILLAGE',ico)
  100.             do ipile=1,piles.proc(/1)
  101.                jcolac= piles.proc(ipile)
  102.                if(jcolac.ne.0) then
  103.                   segact jcolac
  104.                   jlisse=jcolac.ilissg
  105.                   segact jlisse*mod
  106.                   jtlacc=jcolac.kcola(ico)
  107.                   segact jtlacc*mod
  108.                   call ajoun0(jtlacc,MELEME,jlisse,iun)
  109.                   segdes jtlacc
  110.                   segdes jlisse
  111.                   segdes jcolac
  112.                endif
  113.             enddo
  114.             segdes piles
  115.          endif
  116.       ENDIF
  117.       MSOLEN=MSOLIS(4)
  118.       IF(MSOLEN.NE.0) THEN
  119.         SEGACT MSOLEN
  120.         N=ISOLEN(/1)
  121.         IF(N.NE.0) THEN
  122.           DO 210 NN=1,N
  123.           MMODE=ISOLEN(NN)
  124.           SEGSUP MMODE
  125.   210     CONTINUE
  126.         ENDIF
  127.         SEGSUP MSOLEN
  128.       ENDIF
  129.         DO 230 NIP=5,NIPO
  130.         MSOLEN=MSOLIS(NIP)
  131.         IF(MSOLEN.NE.0) THEN
  132.           SEGACT MSOLEN
  133.           N=ISOLEN(/1)
  134.           IF(N.NE.0) THEN
  135.              KSOLIT=MSOLIT(NIP)
  136.              DO 220 NN=1,N
  137.              IRETT=ISOLEN(NN)
  138.              IF(IRETT.NE.0) THEN
  139.                 IF(KSOLIT.EQ.2) THEN
  140.                    CALL DTCHPO(IRETT)
  141.                    IF(IPSAUV.NE.0) THEN
  142.                       ICOLAC = IPSAUV
  143.                       SEGACT ICOLAC
  144.                       ILISSE=ILISSG
  145.                       SEGACT ILISSE*MOD
  146.                       CALL TYPFIL('CHPOINT',ICOCH)
  147.                       ITLACC = KCOLA(ICOCH)
  148.                       SEGACT ITLACC*MOD
  149.                       CALL AJOUN0(ITLACC,IRETT,ILISSE,iun)
  150.                       SEGDES ITLACC
  151.                     ENDIF
  152. C                 Suppression du CHPOINT des piles d'objets communiques
  153.                     if(piComm.gt.0) then
  154.                        piles=piComm
  155.                        segact piles
  156.                        call typfil('CHPOINT',ico)
  157.                        do ipile=1,piles.proc(/1)
  158.                           jcolac= piles.proc(ipile)
  159.                           if(jcolac.ne.0) then
  160.                              segact jcolac
  161.                              jlisse=jcolac.ilissg
  162.                              segact jlisse*mod
  163.                              jtlacc=jcolac.kcola(ico)
  164.                              segact jtlacc*mod
  165.                              call ajoun0(jtlacc,IRETT,jlisse,iun)
  166.                              segdes jtlacc
  167.                              segdes jlisse
  168.                              segdes jcolac
  169.                           endif
  170.                        enddo
  171.                        segdes piles
  172.                     endif
  173.                 ENDIF
  174.                 IF(KSOLIT.EQ.5) THEN
  175.                    CALL DTCHAM(IRETT)
  176.                    IF(IPSAUV.NE.0) THEN
  177.                       ICOLAC = IPSAUV
  178.                       SEGACT ICOLAC
  179.                       ILISSE=ILISSG
  180.                       SEGACT ILISSE*MOD
  181.                       CALL TYPFIL('MCHAML   ',ICOCH)
  182.                       ITLACC = KCOLA(ICOCH)
  183.                       SEGACT ITLACC*MOD
  184.                       CALL AJOUN0(ITLACC,IRETT,ILISSE,iun)
  185.                       SEGDES ITLACC
  186.                     ENDIF
  187. C                 Suppression du MCHAML des piles d'objets communiques
  188.                     if(piComm.gt.0) then
  189.                        piles=piComm
  190.                        segact piles
  191.                        call typfil('MCHAML   ',ico)
  192.                        do ipile=1,piles.proc(/1)
  193.                           jcolac= piles.proc(ipile)
  194.                           if(jcolac.ne.0) then
  195.                              segact jcolac
  196.                              jlisse=jcolac.ilissg
  197.                              segact jlisse*mod
  198.                              jtlacc=jcolac.kcola(ico)
  199.                              segact jtlacc*mod
  200.                              call ajoun0(jtlacc,IRETT,jlisse,iun)
  201.                              segdes jtlacc
  202.                              segdes jlisse
  203.                              segdes jcolac
  204.                           endif
  205.                        enddo
  206.                        segdes piles
  207.                     endif
  208.                 ENDIF
  209.                 IF ( MSOLIT.EQ.10 )  THEN
  210.                 KMEL1 = MSOLIS(3)
  211.                   IF ( NIP.EQ.11 )  THEN
  212.                     CALL ACCTAB(IRRET,'MAILLAGE',
  213.      *                                IVALI,XVALI,ICHARI,LOGII,KMEL1,
  214.      *                                'TABLE   ',
  215.      *                         IVALR,XVALR,ICHARR,LOGIR,ITABR)
  216.                     CALL ACCTAB(ITABR,'MOT     ',
  217.      *                                IVALI,XVALI,MROTS ,LOGII,KMEL1,
  218.      *                                'LISTREEL',
  219.      *                         IVALR,XVALR,ICHARR,LOGIR,IROTS)
  220.                     MLREEL = IROTS
  221.                     SEGSUP MLREEL
  222.                     CALL ACCTAB(ITABR,'MOT     ',
  223.      *                                IVALI,XVALI,MROTP ,LOGII,KMEL1,
  224.      *                                'LISTREEL',
  225.      *                         IVALR,XVALR,ICHARR,LOGIR,IROTP)
  226.                     MLREEL = IROTP
  227.                     SEGSUP MLREEL
  228.                     CALL ACCTAB(ITABR,'MOT     ',
  229.      *                                IVALI,XVALI,MROTD ,LOGII,KMEL1,
  230.      *                                'LISTREEL',
  231.      *                         IVALR,XVALR,ICHARR,LOGIR,IROTD)
  232.                     MLREEL = IROTD
  233.                     SEGSUP MLREEL
  234.                     MTABLE = ITABR
  235.                     SEGSUP MTABLE
  236.                     ITABR  = 0
  237.                     CONTINUE
  238.                     MTABLE = IRRET
  239.                     SEGSUP MTABLE
  240.                     IF(IPSAUV.NE.0) THEN
  241.                       ICOLAC = IPSAUV
  242.                       SEGACT ICOLAC
  243.                       ILISSE=ILISSG
  244.                       SEGACT ILISSE*MOD
  245.                       CALL TYPFIL('LISTREEL',ICOLR)
  246.                       ITLACC = KCOLA(ICOLR)
  247.                       SEGACT ITLACC*MOD
  248.                       CALL AJOUN0(ITLACC,IROTD,ILISSE,iun)
  249.                       CALL AJOUN0(ITLACC,IROTP,ILISSE,iun)
  250.                       CALL AJOUN0(ITLACC,IROTS,ILISSE,iun)
  251.                       SEGDES ITLACC
  252.                       CALL TYPFIL('TABLE   ',ICOTB)
  253.                       ITLACC = KCOLA(ICOTB)
  254.                       SEGACT ITLACC*MOD
  255.                       CALL AJOUN0(ITLACC,ITABR,ILISSE,iun)
  256.                       CALL AJOUN0(ITLACC,IRRET,ILISSE,iun)
  257.                       SEGDES ITLACC
  258.                       SEGDES ICOLAC,ILISSE
  259.                     ENDIF
  260. C                 Suppression du list reel et table des piles d'objets communiques
  261.                     if(piComm.gt.0) then
  262.                        piles=piComm
  263.                        segact piles
  264.                        call typfil('LISTREEL',ico)
  265.                        do ipile=1,piles.proc(/1)
  266.                           jcolac= piles.proc(ipile)
  267.                           if(jcolac.ne.0) then
  268.                              segact jcolac
  269.                              jlisse=jcolac.ilissg
  270.                              segact jlisse*mod
  271.                              jtlacc=jcolac.kcola(ico)
  272.                              segact jtlacc*mod
  273.                              call ajoun0(jtlacc,IROTD,jlisse,iun)
  274.                              call ajoun0(jtlacc,IROTP,jlisse,iun)
  275.                              call ajoun0(jtlacc,IROTS,jlisse,iun)
  276.                              segdes jtlacc
  277.                           endif
  278.                        enddo
  279.                        call typfil('TABLE   ',ico)
  280.                        do ipile=1,piles.proc(/1)
  281.                           jcolac= piles.proc(ipile)
  282.                           if(jcolac.ne.0) then
  283.                              jlisse=jcolac.ilissg
  284.                              jtlacc=jcolac.kcola(ico)
  285.                              segact jtlacc*mod
  286.                              call ajoun0(jtlacc,ITABR,jlisse,iun)
  287.                              call ajoun0(jtlacc,IRRET,jlisse,iun)
  288.                              segdes jtlacc
  289.                              segdes jlisse
  290.                              segdes jcolac
  291.                           endif
  292.                        enddo
  293.                        segdes piles
  294.                     endif
  295.                     IRRET  = 0
  296.                   ELSE IF ( NIP.EQ.12 )  THEN
  297.                     CALL ACCTAB(IRRET,'MAILLAGE',
  298.      *                                IVALI,XVALI,ICHARI,LOGII,KMEL1,
  299.      *                                'TABLE   ',
  300.      *                         IVALR,XVALR,ICHARR,LOGIR,ITABR)
  301.                     CALL ACCTAB(ITABR,'MOT     ',
  302.      *                                IVALI,XVALI,MTRAS ,LOGII,KMEL1,
  303.      *                                'LISTREEL',
  304.      *                         IVALR,XVALR,ICHARR,LOGIR,ITRAS)
  305.                     MLREEL = ITRAS
  306.                     SEGSUP MLREEL
  307.                     CALL ACCTAB(ITABR,'MOT     ',
  308.      *                                IVALI,XVALI,MTRAP ,LOGII,KMEL1,
  309.      *                                'LISTREEL',
  310.      *                         IVALR,XVALR,ICHARR,LOGIR,ITRAP)
  311.                     MLREEL = ITRAP
  312.                     SEGSUP MLREEL
  313.                     CALL ACCTAB(ITABR,'MOT     ',
  314.      *                                IVALI,XVALI,MTRAD ,LOGII,KMEL1,
  315.      *                                'LISTREEL',
  316.      *                         IVALR,XVALR,ICHARR,LOGIR,ITRAD)
  317.                     MLREEL = ITRAD
  318.                     SEGSUP MLREEL
  319.                     MTABLE = ITABR
  320.                     SEGSUP MTABLE
  321.                     CONTINUE
  322.                     MTABLE = IRRET
  323.                     SEGSUP MTABLE
  324.                     IF(IPSAUV.NE.0) THEN
  325.                       ICOLAC = IPSAUV
  326.                       SEGACT ICOLAC
  327.                       ILISSE=ILISSG
  328.                       SEGACT ILISSE*MOD
  329.                       ITLACC = KCOLA(ICOLR)
  330.                       SEGACT ITLACC*MOD
  331.                       CALL AJOUN0(ITLACC,ITRAD,ILISSE,iun)
  332.                       CALL AJOUN0(ITLACC,ITRAP,ILISSE,iun)
  333.                       CALL AJOUN0(ITLACC,ITRAS,ILISSE,iun)
  334.                       SEGDES ITLACC
  335.                       ITLACC = KCOLA(ICOTB)
  336.                       SEGACT ITLACC*MOD
  337.                       CALL AJOUN0(ITLACC,ITABR,ILISSE,iun)
  338.                       CALL AJOUN0(ITLACC,IRRET,ILISSE,iun)
  339.                       SEGDES ITLACC
  340.                       SEGDES ICOLAC,ILISSE
  341.                     ENDIF
  342. C                 Suppression du list reel et table des piles d'objets communiques
  343.                     if(piComm.gt.0) then
  344.                        piles=piComm
  345.                        segact piles
  346.                        call typfil('LISTREEL',ico)
  347.                        do ipile=1,piles.proc(/1)
  348.                           jcolac= piles.proc(ipile)
  349.                           if(jcolac.ne.0) then
  350.                              segact jcolac
  351.                              jlisse=jcolac.ilissg
  352.                              segact jlisse*mod
  353.                              jtlacc=jcolac.kcola(ico)
  354.                              segact jtlacc*mod
  355.                              call ajoun0(jtlacc,ITRAD,jlisse,iun)
  356.                              call ajoun0(jtlacc,ITRAP,jlisse,iun)
  357.                              call ajoun0(jtlacc,ITRAS,jlisse,iun)
  358.                              segdes jtlacc
  359.                           endif
  360.                        enddo
  361.                        call typfil('TABLE   ',ico)
  362.                        do ipile=1,piles.proc(/1)
  363.                           jcolac= piles.proc(ipile)
  364.                           if(jcolac.ne.0) then
  365.                              jlisse=jcolac.ilissg
  366.                              jtlacc=jcolac.kcola(ico)
  367.                              segact jtlacc*mod
  368.                              call ajoun0(jtlacc,ITABR,jlisse,iun)
  369.                              call ajoun0(jtlacc,IRRET,jlisse,iun)
  370.                              segdes jtlacc
  371.                              segdes jlisse
  372.                              segdes jcolac
  373.                           endif
  374.                        enddo
  375.                        segdes piles
  376.                     endif
  377.                     ITABR  = 0
  378.                     IRRET  = 0
  379.                   ENDIF
  380.                 ENDIF
  381.              ENDIF
  382.   220        CONTINUE
  383.           ENDIF
  384.           SEGSUP MSOLEN
  385.         ENDIF
  386.   230   CONTINUE
  387.  1000 CONTINUE
  388.  
  389.       RETURN
  390.       END
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  
  398.  

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