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

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