Télécharger la plaquette Cast3M


fr en

Télécharger pileps.eso

Retour à la liste

Numérotation des lignes : 

pileps

  1. C PILEPS    SOURCE    OF166741  25/02/21    21:18:08     12166          
  2. *
  3. * but : soit deux champs de epsilon il faut trouver le lambda max
  4. *     tel que:   eps1 + lambda*eps2  = signe(eps2) * crit
  5. *
  6.       SUBROUTINE PILEPS
  7.  
  8.       IMPLICIT INTEGER(I-N)
  9.       IMPLICIT REAL*8(A-H,O-Z)
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13.  
  14. -INC SMCHAML
  15. -INC SMLREEL
  16.  
  17.       SEGMENT MZONG
  18.          INTEGER NZONG(0)
  19.       ENDSEGMENT
  20.       SEGMENT MZON1
  21.          INTEGER NZON1(0)
  22.       ENDSEGMENT
  23.       SEGMENT MZON2
  24.          INTEGER NZON2(0)
  25.       ENDSEGMENT
  26.       SEGMENT ITAFF
  27.          INTEGER JTAFF(0)
  28.       ENDSEGMENT
  29.       SEGMENT NOMID
  30.         CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC)
  31.       ENDSEGMENT
  32.  
  33.       PARAMETER ( NINF=3 )
  34.       INTEGER INFOS(NINF)
  35.       CHARACTER*72 MOT
  36.       CHARACTER*16 CONCH1,CONCH2
  37.  
  38. *  lecture des champs et du flottant
  39.        CALL LIROBJ('MCHAML  ',IPCHE1,1,IRETOU)
  40.        CALL ACTOBJ('MCHAML  ',IPCHE1,1)
  41.        IF(IERR.NE.0) RETURN
  42.        CALL LIROBJ('MCHAML  ',IPCHE2,1,IRETOU)
  43.        CALL ACTOBJ('MCHAML  ',IPCHE2,1)
  44.        IF(IERR.NE.0) RETURN
  45.        CALL LIRREE(XCRIT,1,IRETOU)
  46.        IF(IERR.NE.0) RETURN
  47. *  fin de lecture
  48.  
  49.       XLAMB = 1.D+50
  50.  
  51.       IF(IPCHE1.NE.IPCHE2) GOTO 1000
  52. *
  53. *     SI LES 2 POINTEURS SONT EGAUX TRAITEMENT SPECIAL
  54. *
  55.       MCHELM=IPCHE1
  56.       NSOUS = IMACHE(/1)
  57. *
  58.       DO 110 IA=1,NSOUS
  59.          MCHAML=ICHAML(IA)
  60.          ICHAML(IA)=MCHAML
  61.          DO 111 ICOMP=1,IELVAL(/1)
  62.             MELVAL = IELVAL(ICOMP)
  63.             N1PTEL = VELCHE(/1)
  64.             N1EL   = VELCHE(/2)
  65.             IF (N1PTEL.EQ.0) THEN
  66.                CALL ERREUR(19)
  67.                RETURN
  68.             ENDIF
  69.             DO IB = 1, N1EL
  70.               DO IGAU=1,N1PTEL
  71.                 r_z = VELCHE(IGAU,IB)
  72.                 IF ( r_z .NE. 0.D0 ) THEN
  73.                   XLA = (SIGN( XCRIT,r_z ) - r_z) / r_z
  74.                   XLAMB = MIN ( XLAMB , XLA )
  75.                 ENDIF
  76.               ENDDO
  77.             ENDDO
  78.   111    CONTINUE
  79.   110 CONTINUE
  80.       GOTO 777
  81.  
  82. *_______________________________________________________________________
  83. *
  84. *      CAS GENERAL
  85. *_______________________________________________________________________
  86.  1000 CONTINUE
  87.       MCHEL1=IPCHE1
  88.       MCHEL2=IPCHE2
  89. *
  90. *     ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
  91. *     DE SS TYPE DIFFERENTS
  92. *
  93.       IF (MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) THEN
  94.         MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8)
  95.         CALL ERREUR(99)
  96.         IPCHAD=0
  97.         GOTO 666
  98.       ENDIF
  99.  
  100.       NSOUS1=MCHEL1.ICHAML(/1)
  101.       NSOUS2=MCHEL2.ICHAML(/1)
  102. *
  103. * QUELLE BIJECTION ENTRE LES SOUS PAQUETS  SI OUI TRAITEMENT AMELIORE
  104. *
  105.       IF (NSOUS1.NE.NSOUS2) GOTO 4000
  106. *
  107.       SEGINI ITAFF
  108.       DO 17 ISOUS1=1,NSOUS1
  109.          IPMAI1 = MCHEL1.IMACHE(ISOUS1)
  110.          CONCH1  = MCHEL1.CONCHE(ISOUS1)
  111.          DO 18 ISOUS2=1,NSOUS2
  112.             ISOUS=ISOUS2
  113.             IPMAI2= MCHEL2.IMACHE(ISOUS)
  114.             CONCH2= MCHEL2.CONCHE(ISOUS)
  115.             IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN
  116. *
  117. *              VERIFICATION POUR LES INFCHE
  118. *
  119.                CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  120.                IF (IRTD.EQ.0) GOTO 18
  121.                IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  122.                IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  123.                IF (IMINT1.EQ.IMINT2) GOTO 171
  124.                IMINT1 = MCHEL1.INFCHE(ISOUS1,6)
  125.                IMINT2 = MCHEL2.INFCHE(ISOUS2,6)
  126.                IF (IMINT1.EQ.IMINT2) GOTO 171
  127. *
  128. *              ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
  129. *              DE SS TYPE DIFFERENTS
  130.                CALL ERREUR(19)
  131.                SEGSUP ITAFF
  132.                RETURN
  133.             ENDIF
  134.   18     CONTINUE
  135.          SEGSUP ITAFF
  136.          GOTO 4000
  137. *
  138.   171    CONTINUE
  139.          JTAFF(**)=MCHEL2.ICHAML(ISOUS)
  140.   17  CONTINUE
  141. *
  142. *     ON A TROUVE UNE BIJECTION   ET ON VECTORISE
  143. *
  144.       N1=NSOUS1
  145.       DO 400 ISOUS=1,NSOUS1
  146.  
  147.          MCHAML=MCHEL1.ICHAML(ISOUS)
  148. *
  149.          IPCHA=MCHAML
  150. *
  151.          MCHAM2=JTAFF(ISOUS)
  152.          IPCHA2=MCHAM2
  153. *
  154.          CALL PILEP1 (IPCHA2,IPCHA,XLAMB,XCRIT)
  155.          IF (IPCHA.EQ.0) THEN
  156.             SEGSUP ITAFF
  157.             GOTO 9990
  158.          ENDIF
  159. *
  160.   400 CONTINUE
  161.       SEGSUP ITAFF
  162.       GOTO 777
  163. *_______________________________________________________________________
  164. *
  165. *     ON A PAS TROUVE DE BIJECTION
  166. *_______________________________________________________________________
  167. *
  168.  4000 CONTINUE
  169.       SEGINI MZONG,MZON1,MZON2
  170.       DO 500 ISOUS1=1,NSOUS1
  171.          NZONG(**)=MCHEL1.IMACHE(ISOUS1)
  172.          NZON1(**)=ISOUS1
  173.          NZON2(**)=0
  174.   500 CONTINUE
  175.       IWRN=0
  176.       DO 510 ISOUS2=1,NSOUS2
  177.          IPMAI2 = MCHEL2.IMACHE(ISOUS2)
  178.          CONCH2 = MCHEL2.CONCHE(ISOUS2)
  179.          DO 520 ISOUS1=1,NSOUS1
  180.             IPMAI1= MCHEL1.IMACHE(ISOUS1)
  181.             CONCH1= MCHEL1.CONCHE(ISOUS1)
  182.             IF(IPMAI1.EQ.IPMAI2 .AND.CONCH1.EQ.CONCH2) THEN
  183.                CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  184.                IF (IRTD.EQ.0) GOTO 520
  185. *
  186. *              VERIFICATION POUR LES MINTES
  187. *
  188.                IF ( MCHEL1.INFCHE(ISOUS1,4).EQ.
  189.      &              MCHEL2.INFCHE(ISOUS2,4) ) GOTO 530
  190. *
  191. *              ERREUR SUR LES SUPPORTS DES MCHAML
  192. *
  193.                CALL ERREUR(19)
  194.                SEGSUP MZONG,MZON1,MZON2
  195.                RETURN
  196. *
  197.             ENDIF
  198.   520    CONTINUE
  199.          IWRN=1
  200.          NZONG(**)=IPMAI2
  201.          NZON1(**)=0
  202.          NZON2(**)=ISOUS2
  203.          GOTO 510
  204. *
  205.   530    CONTINUE
  206.          NZON2(ISOUS1)=ISOUS2
  207.   510 CONTINUE
  208. *
  209. *   WARNING  LES SOUS ZONES GEOMETRIQUES NE SE CORRESPONDENT PAS 2 A 2
  210. *
  211.       IF(IWRN.EQ.1)  CALL ERREUR(103)
  212.       NSOUS=NZONG(/1)
  213.       N1=NSOUS
  214. *
  215.       DO 540 ISOUS=1,NSOUS
  216.          IF(NZON1(ISOUS).NE.0.AND.NZON2(ISOUS).NE.0) GOTO 550
  217. *
  218.          IF(NZON1(ISOUS).NE.0) THEN
  219.             MCHAML=MCHEL1.ICHAML( NZON1(ISOUS) )
  220.          ENDIF
  221.          IF(NZON2(ISOUS).NE.0) THEN
  222.             MCHAML=MCHEL2.ICHAML( NZON2(ISOUS) )
  223.          ENDIF
  224. *
  225.          GOTO 540
  226. *
  227.   550    CONTINUE
  228.          MCHAML=MCHEL1.ICHAML( NZON1(ISOUS) )
  229.          IPCHAD=MCHAML
  230.          MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
  231.          IPCHA2=MCHAM2
  232. *
  233.          CALL PILEP1 (IPCHA2,IPCHA,XLAMB,XCRIT)
  234.          IF (IPCHA.EQ.0) THEN
  235.             SEGSUP MZONG,MZON1,MZON2
  236.             GOTO 9990
  237.          ENDIF
  238. *
  239.   540 CONTINUE
  240. *
  241.       SEGSUP MZONG,MZON1,MZON2
  242.       GOTO 666
  243. *
  244.  9990 CONTINUE
  245. *
  246. *     ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR
  247. *
  248.       SEGSUP ITAFF
  249.  
  250.       RETURN
  251. *
  252.   666 CONTINUE
  253.   777 CONTINUE
  254.       CALL ECRREE (XLAMB)
  255.  
  256. c      RETURN
  257.       END
  258.  
  259.  
  260.  

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