Télécharger la plaquette Cast3M


fr en

Télécharger actipo.eso

Retour à la liste

Numérotation des lignes : 

actipo

  1. C ACTIPO    SOURCE    CB215821  20/11/25    13:18:10     10792          
  2.       SUBROUTINE ACTIPO(FLOT,IDET,MCHPO1,MCHPO2,MCHPO3,MCHPO4)
  3. C--------------------------------------------------------------------
  4. C              ACCELERATION POUR DES CHAMPOINTS
  5. C--------------------------------------------------------------------
  6.       IMPLICIT INTEGER(I-N)
  7.       IMPLICIT REAL*8(A-H,O-Z)
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC SMCHPOI
  12. -INC SMELEME
  13. -INC SMCOORD
  14. -INC CCREEL
  15.  
  16.       CHARACTER*(LOCOMP) NAMEU(9),NAMEF(9)
  17.       SEGMENT SNOMIN
  18.        CHARACTER*(LOCOMP) NOMIN(0)
  19.       ENDSEGMENT
  20.       SEGMENT ICPR(nbpts)
  21.       SEGMENT/MTRAV/(VA(NIN,KPOI)*D,VB(NIN,KPOI)*D,VC(NIN,KPOI)*D
  22.      .              ,VD(NIN,KPOI)*D,IBIN(NIN,KPOI),IPASS(NIN))
  23.       SEGMENT/MTRBV/(VF(NIN,KPOI)*D)
  24.       DATA NAMEU(1),NAMEU(2),NAMEU(3)/'UX  ','UY  ','UZ  '/
  25.       DATA NAMEU(4),NAMEU(5),NAMEU(6)/'RX  ','RY  ','RZ  '/
  26.       DATA NAMEU(7),NAMEU(8),NAMEU(9)/'UR  ','UT  ','RT  '/
  27.       DATA NAMEF(1),NAMEF(2),NAMEF(3)/'FX  ','FY  ','FZ  '/
  28.       DATA NAMEF(4),NAMEF(5),NAMEF(6)/'MX  ','MY  ','MZ  '/
  29.       DATA NAMEF(7),NAMEF(8),NAMEF(9)/'FR  ','FT  ','MT  '/
  30.       DATA BINF,BSUP/1.D-2,1.D2/
  31.       xp100=xpetit * 100.
  32. C
  33. C  ** ON FABRIQUE UN ICPR SUR LE 3 EME CHPOINT
  34. C
  35.       SEGINI ICPR
  36.       SEGINI SNOMIN
  37.       MCHPOI=MCHPO3
  38.       SEGACT MCHPOI
  39.       KPOI=0
  40.       DO 1 I = 1,IPCHP(/1)
  41.       MSOUPO=IPCHP(I)
  42.       SEGACT MSOUPO
  43.       MELEME=IGEOC
  44.       SEGACT MELEME
  45.       DO 2 K=1,NUM(/2)
  46.       IP=NUM(1,K)
  47.       IF(ICPR(IP).NE.0) GOTO 2
  48.       KPOI=KPOI+1
  49.       ICPR(IP)=KPOI
  50.     2 CONTINUE
  51. C
  52. C  **  RECHERCHE DE TOUTES LES INCONNUES DE CE CHPOINT
  53. C
  54.       IF(I.NE.1) GOTO 3
  55.       DO 4 K=1,NOCOMP(/2)
  56.         NOMIN(**)=NOCOMP(K)
  57.    4  CONTINUE
  58.       GOTO 7
  59.    3  CONTINUE
  60.       NN=NOMIN(/2)
  61.       DO 5 K=1,NOCOMP(/2)
  62.         DO 6 KK=1,NN
  63.           IF(NOMIN(KK).EQ.NOCOMP(K)) GOTO 5
  64.     6   CONTINUE
  65.         NOMIN(**)=NOCOMP(K)
  66.     5 CONTINUE
  67.     7 CONTINUE
  68.     1 CONTINUE
  69.       NIN=NOMIN(/2)
  70.       SEGINI MTRAV
  71. C
  72. C  ON RECUPERE LE 3-EME CHAMP MIS DANS VA
  73. C
  74.       DO 10 I=1,IPCHP(/1)
  75.         MSOUPO=IPCHP(I)
  76.         SEGACT MSOUPO
  77.         MELEME=IGEOC
  78.         SEGACT MELEME
  79.         MPOVAL=IPOVAL
  80.         SEGACT MPOVAL
  81.         DO 11 K=1,NOCOMP(/2)
  82.           DO 12 KK=1,NIN
  83.             IF(NOMIN(KK).EQ.NOCOMP(K)) GOTO 13
  84.    12     CONTINUE
  85.    13     CONTINUE
  86.           IPASS(K)=KK
  87.    11   CONTINUE
  88.         DO 14 K=1,NUM(/2)
  89.           K2= ICPR(NUM(1,K))
  90.           DO 15 KK=1,NOCOMP(/2)
  91.             K1= IPASS(KK)
  92.             IBIN(K1,K2)=1
  93.             VA(K1,K2)=VPOCHA(K,KK)
  94.             VD(K1,K2)=VPOCHA(K,KK)
  95.    15     CONTINUE
  96.    14   CONTINUE
  97.    10 CONTINUE
  98. C
  99. C  ON RECUPERE LE 2-EME CHAMP MIS DANS VB
  100. C
  101.       MCHPOI=MCHPO2
  102.       SEGACT MCHPOI
  103.       DO 20 I=1,IPCHP(/1)
  104.         MSOUPO=IPCHP(I)
  105.         SEGACT MSOUPO
  106.         MELEME=IGEOC
  107.         SEGACT MELEME
  108.         MPOVAL=IPOVAL
  109.         SEGACT MPOVAL
  110.         DO 29 K=1,NIN
  111.           IPASS(K)=0
  112.    29   CONTINUE
  113.         DO 21 K=1,NOCOMP(/2)
  114.           DO 22 KK=1,NIN
  115.             IF(NOMIN(KK).EQ.NOCOMP(K)) GOTO 23
  116.    22     CONTINUE
  117.           GOTO 21
  118.    23     CONTINUE
  119.           IPASS(K)=KK
  120.    21   CONTINUE
  121.         DO 28 K=1,NUM(/2)
  122.           K2= ICPR(NUM(1,K))
  123.           IF(K2.EQ.0) GOTO 28
  124.           DO 24 KK=1,NOCOMP(/2)
  125.             K1=IPASS(KK)
  126.             IF(K1.EQ.0) GOTO 24
  127.             VB(K1,K2)=VPOCHA(K,KK)
  128.    24     CONTINUE
  129.    28   CONTINUE
  130.    20 CONTINUE
  131. C
  132. C  ON RECUPERE LE 1-ER CHAMP MIS DANS VC
  133. C
  134.       MCHPOI=MCHPO1
  135.       SEGACT MCHPOI
  136.       DO 30 I=1,IPCHP(/1)
  137.         MSOUPO=IPCHP(I)
  138.         SEGACT MSOUPO
  139.         MELEME=IGEOC
  140.         SEGACT MELEME
  141.         MPOVAL=IPOVAL
  142.         SEGACT MPOVAL
  143.         DO 39 K=1,NIN
  144.           IPASS(K)=0
  145.    39   CONTINUE
  146.         DO 31 K=1,NOCOMP(/2)
  147.           DO 32 KK=1,NIN
  148.             IF(NOMIN(KK).EQ.NOCOMP(K)) GOTO 33
  149.    32     CONTINUE
  150.           GOTO 31
  151.    33     CONTINUE
  152.           IPASS(K)=KK
  153.    31   CONTINUE
  154.         DO 38 K=1,NUM(/2)
  155.           K2= ICPR(NUM(1,K))
  156.           IF(K2.EQ.0) GOTO 38
  157.           DO 34 KK=1,NOCOMP(/2)
  158.             K1=IPASS(KK)
  159.             IF(K1.EQ.0) GOTO 34
  160.             VC(K1,K2)=VPOCHA(K,KK)
  161.    34     CONTINUE
  162.    38   CONTINUE
  163.    30 CONTINUE
  164. C
  165.       GOTO (2001,2002),IDET
  166. C
  167. C               ACCELERATION GEOMETRIQUE
  168. C
  169.  2001 CONTINUE
  170.       DO 41 K=1,KPOI
  171.         DO 42 I=1,NIN
  172.           RR=VA(I,K)
  173.           IF(IBIN(I,K).EQ.0) GOTO 42
  174.           RD=VB(I,K)-VC(I,K)
  175.           IF(abs(rd).lt.xp100) GOTO 43
  176.           RAI=(VA(I,K)-VB(I,K))/RD
  177.           IF(ABS(RAI).GT.FLOT) GOTO 43
  178.           IF(abs(1.D0-RAI).LE.xp100) GOTO 43
  179.           RR=VA(I,K)+(VA(I,K)-VB(I,K))*RAI/(1.D0-RAI)
  180.    43     CONTINUE
  181.           VD(I,K)=RR
  182.    42   CONTINUE
  183.    41 CONTINUE
  184.       GOTO 3000
  185. C
  186. C               ACCELERATION SECANTE
  187. C
  188.  2002 CONTINUE
  189. C
  190. C  ON RECUPERE LE DERNIER CHAMP DANS VF
  191. C
  192.       SEGINI MTRBV
  193.       MCHPOI=MCHPO4
  194.       SEGACT MCHPOI
  195.       DO 70 I=1,IPCHP(/1)
  196.         MSOUPO=IPCHP(I)
  197.         SEGACT MSOUPO
  198.         MELEME=IGEOC
  199.         SEGACT MELEME
  200.         MPOVAL=IPOVAL
  201.         SEGACT MPOVAL
  202.         DO 79 K=1,NIN
  203.           IPASS(K)=0
  204.    79   CONTINUE
  205.         DO 71 K=1,NOCOMP(/2)
  206.           DO 710 KN=1,9
  207.             IF(NAMEF(KN).EQ.NOCOMP(K)) GOTO 720
  208.  710      CONTINUE
  209.           GOTO 71
  210.  720      CONTINUE
  211.           DO 72 KK=1,NIN
  212.             IF(NOMIN(KK).EQ.NAMEU(KN)) GOTO 73
  213.    72     CONTINUE
  214.           GOTO 71
  215.    73     CONTINUE
  216.           IPASS(K)=KK
  217.    71   CONTINUE
  218.         DO 78 K=1,NUM(/2)
  219.           K2= ICPR(NUM(1,K))
  220.           IF(K2.EQ.0) GOTO 78
  221.           DO 74 KK=1,NOCOMP(/2)
  222.             K1=IPASS(KK)
  223.             IF(K1.EQ.0) GOTO 74
  224.             VF(K1,K2)=VPOCHA(K,KK)
  225.    74     CONTINUE
  226.    78   CONTINUE
  227.    70 CONTINUE
  228. C
  229.       ZNUM=0.D0
  230.       ZDENOM=0.D0
  231.       DO 761 K=1,KPOI
  232.         DO 762 I=1,NIN
  233.           IF(IBIN(I,K).EQ.0) GOTO 762
  234.           ZNUM=ZNUM+VF(I,K)*VC(I,K)
  235.           ZDENOM=ZDENOM+VF(I,K)*(VC(I,K)+VB(I,K)-VA(I,K))
  236.   762   CONTINUE
  237.   761 CONTINUE
  238.       IF(ZDENOM.EQ.0.D0) XMU=1.D0
  239.       IF(ZDENOM.NE.0.D0) XMU=ZNUM/ZDENOM
  240.       IF(ABS(XMU).LT.BINF.OR.ABS(XMU).GT.BSUP) XMU=1.D0
  241.       IF(XMU.EQ.0.D0) XMU=1.D0
  242.       XMUN=1.D0-XMU
  243.       DO 771 K=1,KPOI
  244.         DO 772 I=1,NIN
  245.           IF(IBIN(I,K).EQ.0) GOTO 772
  246.           VD(I,K)=XMU*VA(I,K)+XMUN*VC(I,K)
  247.   772   CONTINUE
  248.   771 CONTINUE
  249. C
  250.  3000 CONTINUE
  251.       SEGACT MCHPO3
  252.       SEGINI,MCHPOI=MCHPO3
  253.       DO 50 I=1,IPCHP(/1)
  254.         MSOUP1=MCHPO3.IPCHP(I)
  255.         SEGACT MSOUP1
  256.         SEGINI,MSOUPO=MSOUP1
  257.         IPCHP(I)=MSOUPO
  258.         MPOVA1=MSOUP1.IPOVAL
  259.         SEGINI,MPOVAL=MPOVA1
  260.         IPOVAL=MPOVAL
  261.         MELEME=IGEOC
  262.         SEGACT MELEME
  263.         DO 51 KK=1,NOCOMP(/2)
  264.           DO 52 K=1,NOMIN(/2)
  265.             IF(NOMIN(K).EQ.NOCOMP(KK)) GOTO 53
  266.    52     CONTINUE
  267.           CALL ERREUR ( 5 )
  268.           RETURN
  269.    53     CONTINUE
  270.           KPA=K
  271.           DO 54 K=1,NUM(/2)
  272.             IP=ICPR(NUM(1,K))
  273.             VPOCHA(K,KK)=VD(KPA,IP)
  274.    54     CONTINUE
  275.    51   CONTINUE
  276.    50 CONTINUE
  277.       SEGSUP SNOMIN,ICPR,MTRAV
  278.       IF(IDET.EQ.2) SEGSUP MTRBV
  279.       CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  280.       CALL ECROBJ('CHPOINT ',MCHPOI)
  281.       END
  282.  
  283.  

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