Télécharger la plaquette Cast3M


fr en

Télécharger sensi1.eso

Retour à la liste

Numérotation des lignes : 

sensi1

  1. C SENSI1    SOURCE    CB215821  16/04/15    21:15:41     8907
  2. *
  3. *
  4. *     BOUCLE SUR LES SOUS ZONES (1 SEUL ELEMENT PAR SOUS ZONE )
  5. *     LELEU DIDIER HAZE FREDERIC
  6. *     03/03/93
  7. *     EXTRAIT DE ADCHEL.ESO
  8. *
  9. *
  10.       SUBROUTINE SENSI1(IPCHE1,IPCHE2,MTAB1)
  11. *
  12. *
  13. *
  14. *
  15. *
  16. *
  17. *     ENTREE :
  18. *     --------
  19. *
  20. *
  21. *        IPCHE1  POINTEUR SUR LE PREMIER CHAMP (TYPE MCHAML)
  22. *        IPCHE2  POINTEUR SUR LE DEUXIEME CHAMP (TYPE MCHALM)
  23. *
  24. *
  25. *     SORTIE :
  26. *     ________
  27. *
  28. *        MTAB1  POINTEUR SUR LA TABLE DERIVEES (TYPE TABLE)
  29. *                = 0  SI L OPERATION EST IMPOSSIBLE
  30. *
  31. *
  32. *
  33. *
  34. *
  35.       IMPLICIT INTEGER(I-N)
  36.       IMPLICIT REAL*8(A-H,O-Z)
  37.       REAL*8 MOYS,A
  38.       CHARACTER*2 B
  39.       LOGICAL C
  40. *
  41. -INC SMCHAML
  42. -INC SMTABLE
  43.  
  44. -INC PPARAM
  45. -INC CCOPTIO
  46. *
  47.       SEGMENT MZONG
  48.          INTEGER NZONG(0)
  49.       ENDSEGMENT
  50. *
  51.       SEGMENT MZON1
  52.          INTEGER NZON1(0)
  53.       ENDSEGMENT
  54. *
  55.       SEGMENT MZON2
  56.          INTEGER NZON2(0)
  57.       ENDSEGMENT
  58. *
  59.       SEGMENT ITAFF
  60.          INTEGER JTAFF(0)
  61.       ENDSEGMENT
  62. *
  63.       SEGMENT MPTVAL
  64.         INTEGER IPOS(NS)    ,NSOF(NS)
  65.         INTEGER      IVAL(NCOSOU)
  66.         CHARACTER*16 TYVAL(NCOSOU)
  67.       ENDSEGMENT
  68. *
  69.       PARAMETER ( NINF=3 )
  70.       INTEGER INFOS(NINF)
  71.       CHARACTER*72 MOT
  72.       CHARACTER*16 CONCH1,CONCH2
  73. *
  74.       A=0.D0
  75.       B='  '
  76.       C=.FALSE.
  77.       IOBIN=0
  78.       IVALRE=0
  79.       IB=0
  80.  
  81.       MCHEL1=IPCHE1
  82.       MCHEL2=IPCHE2
  83.       SEGACT MCHEL1
  84.       SEGACT MCHEL2
  85. *
  86.       L1=MCHEL1.TITCHE(/1)
  87.       MOT=MCHEL1.TITCHE
  88.       IF (MOT.EQ.'NOEUD'.OR.MOT.EQ.'GRAVITE'.OR.MOT.EQ.'RIGIDITE'.
  89.      &    OR.MOT.EQ.'MASSE'.OR.MOT.EQ.'STRESSES'.
  90.      &    OR.MOT.EQ.'SCALAIRE') THEN
  91.          MOT=MCHEL2.TITCHE
  92.          L1=MCHEL2.TITCHE(/1)
  93.       ENDIF
  94.       N3=MCHEL1.INFCHE(/2)
  95.       NSOUS1=MCHEL1.ICHAML(/1)
  96.       NSOUS2=MCHEL2.ICHAML(/1)
  97. *
  98.  
  99. *
  100. * QUELLES BIJECTIONS ENTRE LES SOUS PAQUETS  SI OUI TRAITEMENT AMELIORE
  101. *
  102. *
  103.       SEGINI ITAFF
  104.       DO 17 ISOUS1=1,NSOUS1
  105.          IPMAI1 = MCHEL1.IMACHE(ISOUS1)
  106.          CONCH1  = MCHEL1.CONCHE(ISOUS1)
  107.          DO 18 ISOUS2=1,NSOUS2
  108.             ISOUS=ISOUS2
  109.             IPMAI2= MCHEL2.IMACHE(ISOUS)
  110.             CONCH2= MCHEL2.CONCHE(ISOUS)
  111.             IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN
  112. *
  113. *              VERIFICATION POUR LES INFCHE
  114. *
  115.                CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  116.                IF (IRTD.EQ.0) GOTO 18
  117.                IMINT1=0
  118.                IMINT2=0
  119.               IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  120.               IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  121.               IF (IMINT1.EQ.IMINT2) GOTO 171
  122.                IMINT1=1
  123.                IMINT2=1
  124.               IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6)
  125.               IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6)
  126.                IF (IMINT1.EQ.0) IMINT1=1
  127.                IF (IMINT2.EQ.0) IMINT2=1
  128.                IF (IMINT1.EQ.IMINT2) GOTO 171
  129. *
  130. *              ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
  131. *              DE SS TYPE DIFFERENTS
  132. *
  133.                MOTERR(1:8)=MCHEL1.TITCHE
  134.                MOTERR(9:16)=MCHEL2.TITCHE
  135.                CALL ERREUR(329)
  136.                SEGDES MCHEL1,MCHEL2
  137.                SEGSUP ITAFF
  138.                IPCHAD=0
  139.                RETURN
  140.             ENDIF
  141.   18     CONTINUE
  142.          SEGSUP ITAFF
  143.          GOTO 4000
  144. *
  145.   171    CONTINUE
  146.          JTAFF(**)=MCHEL2.ICHAML(ISOUS)
  147.   17  CONTINUE
  148. *
  149. *     ON A TROUVE UNE BIJECTION   ET ON VECTORISE
  150. *
  151.       N1=NSOUS1
  152.       SEGINI MCHELM
  153.       TITCHE=MOT
  154.       IFOCHE=IFOUR
  155.        M=NSOUS1+1
  156.       SEGINI MTABLE
  157.       MLOTAB=0
  158.       DO 400 ISOUS=1,NSOUS1
  159.          IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
  160.          CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  161.          DO 401 N33=1,N3
  162.                INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33)
  163.  401     CONTINUE
  164. *
  165.          MCHAM1=MCHEL1.ICHAML(ISOUS)
  166. *
  167.          SEGINI,MCHAML=MCHAM1
  168.          ICHAML(ISOUS)=MCHAML
  169.          IPCHA=MCHAML
  170. *
  171.          MCHAM2=JTAFF(ISOUS)
  172.          SEGACT MCHAM2
  173.          IPCHA2=MCHAM2
  174. *
  175.          CALL SENSI2 (IPCHA2,IPCHA,MOYS)
  176.          CALL ECCTAB(MTABLE,'ENTIER',ISOUS,A,B,C
  177.      &           ,IOBIN,'FLOTTANT',IB,MOYS,B,
  178.      &           C,IOBIN)
  179. *
  180.          MOYS=0.D0
  181.          IF (IPCHA.EQ.0) THEN
  182.             SEGSUP ITAFF
  183.             GOTO 9990
  184.          ENDIF
  185. *
  186.          SEGDES MCHAML,MCHAM2
  187.   400 CONTINUE
  188.       MTAB1=MTABLE
  189.       SEGDES MCHEL1,MCHEL2
  190.       SEGSUP ITAFF
  191.       SEGDES MCHELM
  192.       GOTO 666
  193. *_______________________________________________________________________
  194. *
  195. *     ON A PAS TROUVE DE BIJECTION
  196. *_______________________________________________________________________
  197. *
  198.  4000 CONTINUE
  199.       SEGINI MZONG,MZON1,MZON2
  200.       DO 500 ISOUS1=1,NSOUS1
  201.          NZONG(**)=MCHEL1.IMACHE(ISOUS1)
  202.          NZON1(**)=ISOUS1
  203.          NZON2(**)=0
  204.   500 CONTINUE
  205.       IWRN=0
  206.       DO 510 ISOUS2=1,NSOUS2
  207.          IPMAI2 = MCHEL2.IMACHE(ISOUS2)
  208.          CONCH2 = MCHEL2.CONCHE(ISOUS2)
  209.          DO 520 ISOUS1=1,NSOUS1
  210.             IPMAI1= MCHEL1.IMACHE(ISOUS1)
  211.             CONCH1= MCHEL1.CONCHE(ISOUS1)
  212.             IF(IPMAI1.EQ.IPMAI2 .AND.CONCH1.EQ.CONCH2) THEN
  213.                CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  214.                IF (IRTD.EQ.0) GOTO 520
  215. *
  216. *              VERIFICATION POUR LES MINTES
  217. *
  218.                IF ( MCHEL1.INFCHE(ISOUS1,4).EQ.
  219.      &              MCHEL2.INFCHE(ISOUS2,4) ) GOTO 530
  220. *
  221. *              ERREUR SUR LES SUPPORTS DES MCHAML
  222. *
  223.                MOTERR(1:8)=MCHEL1.TITCHE
  224.                MOTERR(9:16)=MCHEL2.TITCHE
  225.                CALL ERREUR(329)
  226.                IPCHAD=0
  227.                SEGDES MCHEL1,MCHEL2
  228.                SEGSUP MZONG,MZON1,MZON2
  229.                RETURN
  230. *
  231.             ENDIF
  232.   520    CONTINUE
  233.          IWRN=1
  234.          NZONG(**)=IPMAI2
  235.          NZON1(**)=0
  236.          NZON2(**)=ISOUS2
  237.          GOTO 510
  238. *
  239.   530    CONTINUE
  240.          NZON2(ISOUS1)=ISOUS2
  241.   510 CONTINUE
  242. *
  243. *   WARNING  LES SOUS ZONES GEOMETRIQUES NE SE CORRESPONDENT PAS 2 A 2
  244. *
  245.       IF(IWRN.EQ.1)  CALL ERREUR(103)
  246.       NSOUS=NZONG(/1)
  247.       N1=NSOUS
  248.       SEGINI MCHELM
  249.       TITCHE=MOT
  250.       IFOCHE=IFOUR
  251.       IPCHAD=MCHELM
  252. *
  253.       DO 540 ISOUS=1,NSOUS
  254.          IF(NZON1(ISOUS).NE.0.AND.NZON2(ISOUS).NE.0) GOTO 550
  255. *
  256.          IF(NZON1(ISOUS).NE.0) THEN
  257.             MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) )
  258.             SEGINI,MCHAML=MCHAM1
  259.             IMACHE(ISOUS)=NZONG(ISOUS)
  260.             CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) )
  261.  
  262.             DO 402 N33=1,N3
  263.                INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33)
  264.  402        CONTINUE
  265. *
  266.          ENDIF
  267.          IF(NZON2(ISOUS).NE.0) THEN
  268.             MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
  269.             SEGINI,MCHAML=MCHAM2
  270.             IMACHE(ISOUS)=NZONG(ISOUS)
  271.             CONCHE(ISOUS)=MCHEL2.CONCHE( NZON2(ISOUS) )
  272.  
  273.             DO 403 N33=1,N3
  274.                INFCHE(ISOUS,N33)=MCHEL2.INFCHE(NZON2(ISOUS),N33)
  275.  403        CONTINUE
  276. *
  277.          ENDIF
  278.          ICHAML(ISOUS)=MCHAML
  279. *
  280.          DO 175 ICOMP=1,IELVAL(/1)
  281.             MELVA1=IELVAL(ICOMP)
  282.             SEGINI,MELVAL=MELVA1
  283.             IELVAL(ICOMP)=MELVAL
  284.             SEGDES MELVAL
  285.  175     CONTINUE
  286.          SEGDES MCHAML
  287. *
  288.          GOTO 540
  289. *
  290.   550    CONTINUE
  291.          MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) )
  292.          SEGINI,MCHAML=MCHAM1
  293.          IMACHE(ISOUS)=NZONG(ISOUS)
  294.          CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) )
  295.  
  296.          DO 404 N33=1,N3
  297.             INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33)
  298.  404     CONTINUE
  299.          ICHAML(ISOUS)=MCHAML
  300.          IPCHA=MCHAML
  301.          MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
  302.          SEGACT MCHAM2
  303.          IPCHA2=MCHAM2
  304. *
  305.          CALL SENSI2 (IPCHA2,IPCHA,MOYS)
  306.          IF (IPCHA.EQ.0) THEN
  307.             SEGSUP MZONG,MZON1,MZON2
  308.             GOTO 9990
  309.          ENDIF
  310. *
  311.          SEGDES MCHAML,MCHAM2
  312.   540 CONTINUE
  313.       SEGDES MCHELM
  314. *
  315.       SEGSUP MZONG,MZON1,MZON2
  316.       GOTO 666
  317. *
  318.  9990 CONTINUE
  319. *
  320. *     ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR
  321. *
  322.       SEGDES MCHEL1,MCHEL2,MCHAM2
  323.       SEGSUP MCHAML,MCHELM,ITAFF
  324.       IPCHAD=0
  325.       RETURN
  326. *
  327.   666 CONTINUE
  328.       SEGDES MCHEL1,MCHEL2
  329.   777 CONTINUE
  330.       RETURN
  331.       END
  332.  
  333.  
  334.  
  335.  
  336.  
  337.  
  338.  

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