Télécharger la plaquette Cast3M


fr en

Télécharger dtsolz.eso

Retour à la liste

Numérotation des lignes : 

dtsolz

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

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