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

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