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

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