Télécharger la plaquette Cast3M


fr en

Télécharger actich.eso

Retour à la liste

Numérotation des lignes : 

actich

  1. C ACTICH    SOURCE    CB215821  20/11/04    21:15:00     10766          
  2.       SUBROUTINE ACTICH(FLOT,IPCH1,IPCH2,IPCH3,MACOMP,IPCH4)
  3.  
  4. C--------------------------------------------------------------------
  5. C          ACCELERATION SUR UNE COMPOSANTE D'UN CHAMELEM
  6. C--------------------------------------------------------------------
  7.       IMPLICIT INTEGER(I-N)
  8.       IMPLICIT REAL*8(A-H,O-Z)
  9. -INC SMCHAML
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. *
  14.       SEGMENT NOMID
  15.         CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC)
  16.       ENDSEGMENT
  17. *
  18.       SEGMENT NOTYPE
  19.  
  20.         CHARACTER*16 TYPE(NBTYPE)
  21.       ENDSEGMENT
  22. *
  23.       SEGMENT MPTVAL
  24.         INTEGER IPOS(NS)    ,NSOF(NS)
  25.         INTEGER      IVAL(NCOSOU)
  26.         CHARACTER*16 TYVAL(NCOSOU)
  27.       ENDSEGMENT
  28. *
  29.       PARAMETER ( NINF=3 )
  30.       INTEGER INFOS(NINF)
  31.       CHARACTER*(LOCOMP) MACOMP
  32.       CHARACTER*16 MOT1,MOT2,MOT3
  33.       CHARACTER*(nconch) CONM
  34. *
  35. *
  36. *     Verification  du lieu support des MCHAMLs
  37. *
  38.       CALL QUESUP (0,IPCH1,0,0,ISUP1,IRET1)
  39.       IF(IERR.NE.0)RETURN
  40.       CALL QUESUP (0,IPCH2,0,0,ISUP2,IRET2)
  41.       IF(IERR.NE.0)RETURN
  42.       CALL QUESUP (0,IPCH3,0,0,ISUP3,IRET3)
  43.       IF(IERR.NE.0)RETURN
  44.       IF((ISUP1.EQ.ISUP2.AND.ISUP1.EQ.ISUP3)
  45.      1            .OR.
  46.      1  ((ISUP1.EQ.0.AND.ISUP2.EQ.0).OR.
  47.      1   (ISUP2.EQ.0.AND.ISUP3.EQ.0).OR.
  48.      1   (ISUP3.EQ.0.AND.ISUP1.EQ.0))
  49.      1           .OR.
  50.      1  ((ISUP1.EQ.0.AND.ISUP2.EQ.ISUP3).OR.
  51.      1   (ISUP2.EQ.0.AND.ISUP3.EQ.ISUP1).OR.
  52.      1   (ISUP3.EQ.0.AND.ISUP1.EQ.ISUP2)))THEN
  53.         IOK=1
  54.       ELSE
  55.          IOK=0
  56.       ENDIF
  57.       IF(IOK.EQ.0)THEN
  58.          MCHELM=IPCH1
  59.          SEGACT MCHELM
  60.          MOTERR(1:8)=TITCHE
  61.          CALL ERREUR(124)
  62.          SEGDES MCHELM
  63.          RETURN
  64.       ENDIF
  65. C
  66. C   ON COPIE LE TROISIEME MCHAML
  67. C
  68.  
  69.       CALL COPIE8(IPCH3,IPCH4)
  70.       MCHEL1=IPCH1
  71.       MCHEL2=IPCH2
  72.       MCHEL3=IPCH3
  73.       SEGACT,MCHEL1,MCHEL2,MCHEL3
  74.       MOT1=MCHEL1.TITCHE
  75.       MOT2=MCHEL2.TITCHE
  76.       MOT3=MCHEL3.TITCHE
  77.       IF(MOT1.NE.MOT2.OR.MOT1.NE.MOT3)THEN
  78.         CALL ERREUR(253)
  79.         CALL DTCHAM(IPCH4)
  80.         GOTO 666
  81.       ENDIF
  82.       MCHEL4=IPCH4
  83.       SEGACT MCHEL4
  84.       NSOU4=MCHEL4.IMACHE(/1)
  85. C
  86. C     BOUCLE SUR LES ZONES
  87. C
  88.       DO 500 ISOUS=1,NSOU4
  89. C
  90.       IPMAIL=MCHEL4.IMACHE(ISOUS)
  91.       CONM=MCHEL4.CONCHE(ISOUS)
  92. C
  93. C     CREATION DU TABLEAU INFOS
  94. C
  95.       CALL IDENT(IPMAIL,CONM,IPCH1,IPCH2,INFOS,IRTD)
  96.       IF (IRTD.EQ.0) THEN
  97.         SEGDES MCHEL4
  98.         CALL DTCHAM(IPCH4)
  99.         GOTO 666
  100.       ENDIF
  101. C
  102.       MCHAML=MCHEL4.ICHAML(ISOUS)
  103.       SEGACT MCHAML
  104.       NCOMP=IELVAL(/1)
  105.       NBRFAC=0
  106.       NBTYPE=NCOMP
  107.       SEGINI NOTYPE
  108.       MOTYPE=NOTYPE
  109.       NBROBL=NCOMP
  110.       SEGINI NOMID
  111.       MONOM=NOMID
  112.       DO  10 IC=1,NCOMP
  113.         LESOBL(IC)=NOMCHE(IC)
  114.         TYPE(IC)=TYPCHE(IC)
  115.  10   CONTINUE
  116. C
  117.        NUMCO=0
  118.        IF(NCOMP.EQ.1)NUMCO=1
  119.        IF(NCOMP.NE.1)THEN
  120.          DO 20 IC=1,NCOMP
  121.            IF(MACOMP.NE.NOMCHE(IC))GOTO 20
  122.            NUMCO=IC
  123.            GO TO 30
  124.   20    CONTINUE
  125.   30    CONTINUE
  126.       ENDIF
  127.         IF(NUMCO.EQ.0)THEN
  128.           MOTERR(1:4)=MACOMP
  129.           CALL ERREUR(243)
  130.           SEGDES MCHAML
  131.           SEGDES MCHEL4
  132.           CALL DTCHAM(IPCH4)
  133.           GO TO 666
  134.          ENDIF
  135. C
  136. C     ON VERIFIE SI ON A LES MEMES COMPOSANTES SUR LES AUTRES
  137. C     CHAMPS ET ON LES EXTRAIT
  138. C
  139.       CALL KOMCHA(IPCH1,IPMAIL,CONM,MONOM,MOTYPE,1,INFOS,3,IVACH1)
  140.       IF(IERR.NE.0)THEN
  141.         SEGSUP NOMID,NOTYPE
  142.         CALL DTMVAL(IVACH1,1)
  143.         SEGDES MCHAML
  144.         SEGDES MCHEL4
  145.         CALL DTCHAM(IPCH4)
  146.         GO TO 666
  147.        ENDIF
  148.       CALL KOMCHA(IPCH2,IPMAIL,CONM,MONOM,MOTYPE,1,INFOS,3,IVACH2)
  149.       IF(IERR.NE.0)THEN
  150.         SEGSUP NOMID,NOTYPE
  151.         CALL DTMVAL(IVACH1,1)
  152.         CALL DTMVAL(IVACH2,1)
  153.         SEGDES MCHAML
  154.         SEGDES MCHEL4
  155.         CALL DTCHAM(IPCH4)
  156.         GO TO 666
  157.        ENDIF
  158.       CALL KOMCHA(IPCH3,IPMAIL,CONM,MONOM,MOTYPE,1,INFOS,3,IVACH3)
  159.       SEGSUP NOMID,NOTYPE
  160. C
  161.       MELVAL=IELVAL(NUMCO)
  162.       SEGACT,MELVAL
  163.       NBPTE4=VELCHE(/1)
  164.       NEL4  =VELCHE(/2)
  165.       MPTVAL=IVACH1
  166.       MELVAL=IVAL(NUMCO)
  167.       NBPTE1=VELCHE(/1)
  168.       NEL1  =VELCHE(/2)
  169.       MPTVAL=IVACH2
  170.       MELVAL=IVAL(NUMCO)
  171.       NBPTE2=VELCHE(/1)
  172.       NEL2  =VELCHE(/2)
  173.       NBPTEL=MAX(MAX(NBPTE1,NBPTE2),NBPTE4)
  174.       NBELEM=MAX(MAX(NEL1,NEL2),NEL4)
  175.       N1PTEL=NBPTEL
  176.       N1EL=NBELEM
  177.       N2PTEL=0
  178.       N2EL=0
  179.       MELVAL=IELVAL(NUMCO)
  180.       IF(N1PTEL.GT.NBPTE4.OR.N1EL.GT.NEL4)SEGADJ MELVAL
  181. C
  182.       DO 100 IB=1,NBELEM
  183.         DO 100 IGAU=1,NBPTEL
  184. C
  185.           MPTVAL=IVACH1
  186.           MELVAL=IVAL(NUMCO)
  187.           IGMN=MIN(IGAU,VELCHE(/1))
  188.           IBMN=MIN(IB,VELCHE(/2))
  189.           V1=VELCHE(IGMN,IBMN)
  190. C
  191.           MPTVAL=IVACH2
  192.           MELVAL=IVAL(NUMCO)
  193.           IGMN=MIN(IGAU,VELCHE(/1))
  194.           IBMN=MIN(IB,VELCHE(/2))
  195.           V2=VELCHE(IGMN,IBMN)
  196. C
  197.           MPTVAL=IVACH3
  198.           MELVAL=IVAL(NUMCO)
  199.           IGMN=MIN(IGAU,VELCHE(/1))
  200.           IBMN=MIN(IB,VELCHE(/2))
  201.           V3=VELCHE(IGMN,IBMN)
  202. C
  203.           RR=V3
  204.           RD=V2-V1
  205.           IF(RD.EQ.0.D0) GO TO 50
  206.           RAI=(V3-V2)/RD
  207.           IF(ABS(RAI).GT.FLOT) GO TO 50
  208.           IF(RAI.EQ.1.D0) GO TO 50
  209.           RR=V3+(V3-V2)*RAI/(1.D0-RAI)
  210.    50     CONTINUE
  211.           MELVAL=IELVAL(NUMCO)
  212.           VELCHE(IGAU,IB)=RR
  213.   100  CONTINUE
  214. C
  215. C    DESACTIVATION DES SEGMENTS
  216. C
  217. C
  218.         CALL DTMVAL(IVACH1,1)
  219. C
  220.         CALL DTMVAL(IVACH2,1)
  221. C
  222.         CALL DTMVAL(IVACH3,1)
  223. C
  224.           MELVAL=IELVAL(NUMCO)
  225.           SEGDES MELVAL
  226.           SEGDES MCHAML
  227. C
  228.   500  CONTINUE
  229.         SEGDES MCHEL4
  230.  666   CONTINUE
  231.        SEGDES MCHEL1,MCHEL2,MCHEL3
  232.        RETURN
  233.        END
  234.  
  235.  

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