Télécharger la plaquette Cast3M


fr en

Télécharger adchel.eso

Retour à la liste

Numérotation des lignes : 

adchel

  1. C ADCHEL    SOURCE    OF166741  24/10/03    21:15:03     12022          
  2.       SUBROUTINE ADCHEL(IPCHE1,IPCHE2,IPCHAD,IEPS)
  3. C_______________________________________________________________________
  4. C
  5. C         ADDITION / SOUSTRACTION DE 2 CHPS PAR ELEMENTS
  6. C
  7. C         ( ADDITION :IEPS=1 ; SOUSTRACTION IEPS=-1 )
  8. C
  9. C     ENTREE :
  10. C     --------
  11. C
  12. C        IPCHE1  POINTEUR SUR LE PREMIER CHAMPS (TYPE MCHAML)
  13. C        IPCHE2  POINTEUR SUR LE DEUXIEME CHAMPS (TYPE MCHALM)
  14. C        IEPS    = 1  ADDITION
  15. C                =-1  SOUSTRACTION
  16. C
  17. C     SORTIE :
  18. C     ________
  19. C
  20. C        IPCHAD  POINTEUR SUR LE CHAMPS SOMME (TYPE MCHAML)
  21. C                = 0  SI L OPERATION EST IMPOSSIBLE
  22. C
  23. C         MESSAGE D ERREUR DECHENCHE SI IPCHAD=0
  24. C
  25. C     LES 2 CHAM PAR ELEMENT PEUVENT AVOIR DES SUPPORTS GEOMETRIQUES
  26. C     DIFFERENTS POUR PEU QUE LES OBJETS AFFECTES ELEMENTAIRES QUI LES
  27. C     SOUS TENDENT   FORMENT UNE PARTITION DE LA GEOMETRIE
  28. C
  29. C     CODE EBERSOLT JUILLET 84   PASSAGE 4331 FEVRIER 85
  30. C
  31. C    ON PEUT ADDITIONNER A UN CHAMELEM QUELCONQUE UN CHAMELEM A UNE
  32. C   COMPOSANTE
  33. C
  34. C     MODIFIE SEPTEMBRE 86
  35. C
  36. C     PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 29 10 90
  37. C +PP     EXTENSION ADDITION P.PEGON 24/11/92
  38. C
  39. C     CB215821 : Gestion de la soustraction avec des SOUS-ZONES disjointes
  40. C_______________________________________________________________________
  41. C
  42.       IMPLICIT INTEGER(I-N)
  43.       IMPLICIT REAL*8(A-H,O-Z)
  44.  
  45. -INC PPARAM
  46. -INC CCOPTIO
  47.  
  48. -INC SMCHAML
  49. -INC SMLREEL
  50. -INC SMCOORD
  51.  
  52.       CHARACTER*16 TYPCH2
  53.  
  54.       SEGMENT MZONG
  55.         INTEGER NZONG(0)
  56.       ENDSEGMENT
  57.  
  58.       SEGMENT MZON1
  59.         INTEGER NZON1(0)
  60.       ENDSEGMENT
  61.  
  62.       SEGMENT MZON2
  63.         INTEGER NZON2(0)
  64.       ENDSEGMENT
  65. C
  66.       SEGMENT ITAFF
  67.         INTEGER JTAFF(0)
  68.       ENDSEGMENT
  69. C
  70.       SEGMENT MPTVAL
  71.         INTEGER IPOS(NS)    ,NSOF(NS)
  72.         INTEGER      IVAL(NCOSOU)
  73.         CHARACTER*16 TYVAL(NCOSOU)
  74.       ENDSEGMENT
  75. C
  76.       PARAMETER ( NINF=3 )
  77.       INTEGER INFOS(NINF)
  78.       CHARACTER*72 MOT
  79.       CHARACTER*16 CONCH1,CONCH2
  80.       LOGICAL      BOOLSO
  81. C
  82.       BOOLSO=.FALSE.
  83.  
  84.       IF(IEPS.EQ. 1) XX= 1.D0
  85.       IF(IEPS.EQ.-1) XX=-1.D0
  86. C      if (ieps.eq.-1) then
  87. C        write (6,*) ' adchel soustraction de chamelem '
  88. C      endif
  89.  
  90.       IF(IPCHE1.NE.IPCHE2) GOTO 1000
  91. C
  92. C     SI LES 2 POINTEURS SONT EGAUX TRAITEMENT SPECIAL
  93. C
  94.       MCHEL1=IPCHE1
  95.       MCHEL2=IPCHE2
  96.       SEGINI,MCHELM=MCHEL1
  97.       IPCHAD = MCHELM
  98.       NSOUS = IMACHE(/1)
  99.       IF (IEPS.EQ. 1) XX=2.D0
  100.       IF (IEPS.EQ.-1) XX=0.D0
  101.  
  102.       DO 110 IA=1,NSOUS
  103.          MCHAM1=ICHAML(IA)
  104.          SEGINI,MCHAML=MCHAM1
  105.          ICHAML(IA)=MCHAML
  106.          DO 111 ICOMP=1,IELVAL(/1)
  107.             MELVA1 = IELVAL(ICOMP)
  108.             SEGINI,MELVAL=MELVA1
  109.             N1PTEL=VELCHE(/1)
  110.             IF (N1PTEL.EQ.0) THEN
  111.                N2PTEL=IELCHE(/1)
  112.                N2EL  =IELCHE(/2)
  113.                IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  114.                   DO 122 IB=1,N2EL
  115.                      DO 121 IGAU=1,N2PTEL
  116.                         MLREE1=IELCHE(IGAU,IB)
  117.                         IF(MLREE1.EQ.0)THEN
  118.                            MLREEL=MLREE1
  119.                         ELSE
  120.                            SEGACT MLREE1
  121.                            JG=MLREE1.PROG(/1)
  122.                            SEGINI MLREEL
  123.                            DO 123 IPROG=1,JG
  124.                               PROG(IPROG)=XX*MLREE1.PROG(IPROG)
  125.  123                       CONTINUE
  126.                         ENDIF
  127.                         IELCHE(IGAU,IB)=MLREEL
  128.  121                 CONTINUE
  129.  122              CONTINUE
  130.                ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
  131.                   DO 126 IB=1,N2EL
  132.                      DO 125 IGAU=1,N2PTEL
  133.                         MEVOL1=IELCHE(IGAU,IB)
  134.                         CALL ADEVOL(MEVOL1,MEVOL1,MEVOL2,IEPS)
  135.                         IELCHE(IGAU,IB)=MEVOL2
  136.  125                 CONTINUE
  137.  126              CONTINUE
  138.                ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT   ') THEN
  139.                   SEGACT,MCOORD*mod
  140.                   NBNO=NBPTS
  141.                   NBNOI=NBNO
  142.                   NBPTS=NBNO+(N2PTEL*N2EL)
  143.                   SEGADJ,MCOORD
  144.                   DO 132 IB=1,N2EL
  145.                      DO 131 IGAU=1,N2PTEL
  146.                         IP=IELCHE(IGAU,IB)
  147.                         IF(IP.EQ.0)THEN
  148.                            NBPTS=IP
  149.                         ELSE
  150.                            IREF=(IP-1)*(IDIM+1)
  151.                            DO 133 IC=1,IDIM
  152.                            XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XX
  153.  133                       CONTINUE
  154.                      XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1))
  155.                         ENDIF
  156.                         IELCHE(IGAU,IB)=NBNOI+1
  157.                         NBNOI=NBNOI+1
  158.  131                 CONTINUE
  159.  132              CONTINUE
  160.                ELSE
  161. C
  162. C                 NOM DE COMPOSANTE NON RECONNU
  163. C
  164.                   MOTERR(1:4)=NOMCHE(ICOMP)
  165.                   CALL ERREUR(197)
  166.                   IPCHAD=0
  167.                   SEGSUP MELVAL,MCHAML,MCHELM
  168.                   RETURN
  169.                ENDIF
  170.             ELSE
  171.                N1EL=VELCHE(/2)
  172.                DO IB=1,N1EL
  173.                   DO IGAU=1,N1PTEL
  174.                      VELCHE(IGAU,IB)=XX*VELCHE(IGAU,IB)
  175.                   ENDDO
  176.                ENDDO
  177.             ENDIF
  178.             IELVAL(ICOMP) = MELVAL
  179.   111    CONTINUE
  180.   110 CONTINUE
  181.       GOTO 777
  182.  
  183. C_______________________________________________________________________
  184. C
  185. C      CAS GENERAL
  186. C_______________________________________________________________________
  187. C
  188.  1000 CONTINUE
  189.       MCHEL1=IPCHE1
  190.       MCHEL2=IPCHE2
  191.       SEGACT,MCHEL1,MCHEL2
  192. C
  193. C     ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
  194. C     DE SS TYPE DIFFERENTS
  195. C
  196.       IF (MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) THEN
  197.         MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8)
  198.         CALL ERREUR(99)
  199.         IPCHAD=0
  200.         GOTO 666
  201.       ENDIF
  202. C
  203.       MOT=MCHEL1.TITCHE
  204.       L1=MCHEL1.TITCHE(/1)
  205.       IF (MOT.EQ.'NOEUD'.OR.MOT.EQ.'GRAVITE' .OR.MOT.EQ.'RIGIDITE'.OR.
  206.      &    MOT.EQ.'MASSE'.OR.MOT.EQ.'STRESSES'.OR.MOT.EQ.'SCALAIRE') THEN
  207.          MOT= MCHEL2.TITCHE
  208.          L1 = MCHEL2.TITCHE(/1)
  209.       ENDIF
  210.       N3    =MCHEL1.INFCHE(/2)
  211. C* On doit avoir N3=6
  212.       NSOUS1=MCHEL1.ICHAML(/1)
  213.       NSOUS2=MCHEL2.ICHAML(/1)
  214. C
  215. C QUELLE BIJECTION ENTRE LES SOUS PAQUETS  SI OUI TRAITEMENT AMELIORE
  216. C
  217.       IF (NSOUS1.NE.NSOUS2) GOTO 4000
  218. C
  219.       SEGINI ITAFF
  220.       DO 17 ISOUS1=1,NSOUS1
  221.          IPMAI1 = MCHEL1.IMACHE(ISOUS1)
  222.          CONCH1 = MCHEL1.CONCHE(ISOUS1)
  223.          DO 18 ISOUS2=1,NSOUS2
  224.             ISOUS=ISOUS2
  225.             IPMAI2= MCHEL2.IMACHE(ISOUS)
  226.             CONCH2= MCHEL2.CONCHE(ISOUS)
  227.             IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN
  228. C
  229. C              VERIFICATION POUR LES INFCHE
  230. C
  231.                CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  232.                IF (IRTD.EQ.0) GOTO 18
  233.                IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  234.                IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  235.                IF (IMINT1.EQ.IMINT2) GOTO 171
  236.                IMINT1 = MCHEL1.INFCHE(ISOUS1,6)
  237. c*               IF (IMINT1.EQ.0) IMINT1 = 1
  238.                IMINT2 = MCHEL2.INFCHE(ISOUS2,6)
  239. c*               IF (IMINT2.EQ.0) IMINT2 = 1
  240.                IF (IMINT1.EQ.IMINT2) GOTO 171
  241. C
  242. C              ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
  243. C              DE SS TYPE DIFFERENTS
  244. C
  245.                MOTERR(1:8)=MCHEL1.TITCHE
  246.                MOTERR(9:16)=MCHEL2.TITCHE
  247.                CALL ERREUR(329)
  248.                SEGSUP ITAFF
  249.                IPCHAD=0
  250.                RETURN
  251.             ENDIF
  252.   18     CONTINUE
  253.          SEGSUP ITAFF
  254.          GOTO 4000
  255.  
  256.   171    CONTINUE
  257. C        Ici, les zones ISOUS1 et ISOUS2 ont meme maillage,
  258. c        meme constituant, meme segment d'integration
  259.          JTAFF(**)=MCHEL2.ICHAML(ISOUS)
  260.  
  261.   17  CONTINUE
  262. C
  263. C     ON A TROUVE UNE BIJECTION ET ON VECTORISE
  264. C
  265.       N1=NSOUS1
  266. C*      N3 = 6
  267.       SEGINI MCHELM
  268.       TITCHE=MOT
  269.       IFOCHE=IFOUR
  270.       IPCHAD=MCHELM
  271.       DO 400 ISOUS=1,NSOUS1
  272.          IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
  273.          CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  274.          DO 401 N33=1,N3
  275.             INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33)
  276.  401     CONTINUE
  277. C
  278.          MCHAM1=MCHEL1.ICHAML(ISOUS)
  279. C
  280.          SEGINI,MCHAML=MCHAM1
  281.          ICHAML(ISOUS)=MCHAML
  282.          IPCHA=MCHAML
  283. C
  284.          MCHAM2=JTAFF(ISOUS)
  285.          SEGACT MCHAM2
  286.          IPCHA2=MCHAM2
  287. C
  288.          CALL ADCHAM (IPCHA2,IPCHA,XX)
  289.          IF (IPCHA.EQ.0) THEN
  290.             SEGSUP ITAFF
  291.             GOTO 9990
  292.          ENDIF
  293. C
  294.   400 CONTINUE
  295.       SEGSUP ITAFF
  296.       GOTO 666
  297. C_______________________________________________________________________
  298. C
  299. C     ON A PAS TROUVE DE BIJECTION
  300. C_______________________________________________________________________
  301. C
  302.  4000 CONTINUE
  303.       SEGINI MZONG,MZON1,MZON2
  304.       DO 500 ISOUS1=1,NSOUS1
  305.          NZONG(**)=MCHEL1.IMACHE(ISOUS1)
  306.          NZON1(**)=ISOUS1
  307.          NZON2(**)=0
  308.   500 CONTINUE
  309.       IWRN=0
  310.       DO 510 ISOUS2=1,NSOUS2
  311.          IPMAI2 = MCHEL2.IMACHE(ISOUS2)
  312.          CONCH2 = MCHEL2.CONCHE(ISOUS2)
  313.          DO 520 ISOUS1=1,NSOUS1
  314.             IPMAI1= MCHEL1.IMACHE(ISOUS1)
  315.             CONCH1= MCHEL1.CONCHE(ISOUS1)
  316.             IF (IPMAI1.EQ.IPMAI2 .AND.CONCH1.EQ.CONCH2) THEN
  317.                CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  318.                IF (IRTD.EQ.0) GOTO 520
  319. C
  320. C              VERIFICATION POUR LES MINTES
  321. C
  322.                IF ( MCHEL1.INFCHE(ISOUS1,6).EQ.
  323.      &              MCHEL2.INFCHE(ISOUS2,6) ) GOTO 530
  324. C
  325. C              ERREUR SUR LES SUPPORTS DES MCHAML
  326. C
  327.                MOTERR(1:8) =MCHEL1.TITCHE
  328.                MOTERR(9:16)=MCHEL2.TITCHE
  329.                CALL ERREUR(329)
  330.                IPCHAD=0
  331.                SEGSUP MZONG,MZON1,MZON2
  332.                RETURN
  333.             ENDIF
  334.   520    CONTINUE
  335.          IWRN=1
  336.          NZONG(**)=IPMAI2
  337.          NZON1(**)=0
  338.          NZON2(**)=ISOUS2
  339.          GOTO 510
  340. C
  341.   530    CONTINUE
  342.          if (nzon2(isous1).ne.0) call erreur(329)
  343.          NZON2(ISOUS1)=ISOUS2
  344.   510 CONTINUE
  345. C
  346. C   WARNING  LES SOUS ZONES GEOMETRIQUES NE SE CORRESPONDENT PAS 2 A 2
  347. C
  348.       NSOUS=NZONG(/1)
  349.       N1=NSOUS
  350. C*      N3=6
  351.       SEGINI MCHELM
  352.       TITCHE=MOT
  353.       IFOCHE=IFOUR
  354.       IPCHAD=MCHELM
  355. C
  356.       DO 540 ISOUS=1,NSOUS
  357.          BOOLSO=.FALSE.
  358.          IF(NZON1(ISOUS).NE.0.AND.NZON2(ISOUS).NE.0) GOTO 550
  359. C
  360.          IF(NZON1(ISOUS).NE.0) THEN
  361.             MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) )
  362.             SEGINI,MCHAML=MCHAM1
  363.             IMACHE(ISOUS)=NZONG(ISOUS)
  364.             CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) )
  365.             DO 402 N33=1,N3
  366.                INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33)
  367.  402        CONTINUE
  368.          ENDIF
  369.          IF(NZON2(ISOUS).NE.0) THEN
  370.             IF(IEPS .EQ. -1) BOOLSO=.TRUE.
  371.             MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
  372.             SEGINI,MCHAML=MCHAM2
  373.             IMACHE(ISOUS)=NZONG(ISOUS)
  374.             CONCHE(ISOUS)=MCHEL2.CONCHE( NZON2(ISOUS) )
  375.             DO 403 N33=1,N3
  376.                INFCHE(ISOUS,N33)=MCHEL2.INFCHE(NZON2(ISOUS),N33)
  377.  403        CONTINUE
  378.          ENDIF
  379.          ICHAML(ISOUS)=MCHAML
  380. C
  381.          DO 175 ICOMP=1,IELVAL(/1)
  382.             MELVA1=IELVAL(ICOMP)
  383.             SEGINI,MELVAL=MELVA1
  384.             IELVAL(ICOMP)=MELVAL
  385. C CB215821  Si c'est la soustraction qu'on demande il faut faire * XX...
  386. C           sur les SOUS-ZONES issues du 2ème MCHAML (BOOLSO = .TRUE.)
  387.             IF (BOOLSO) THEN
  388.                 TYPCH2=TYPCHE(ICOMP)
  389.                 CALL MULMEL(MELVAL,XX,TYPCH2)
  390.             ENDIF
  391.  175     CONTINUE
  392. C
  393.          GOTO 540
  394. C
  395.   550    CONTINUE
  396.          MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) )
  397.          SEGINI,MCHAML=MCHAM1
  398.          IMACHE(ISOUS)=NZONG(ISOUS)
  399.          CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) )
  400.          DO 404 N33=1,N3
  401.             INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33)
  402.  404     CONTINUE
  403.          ICHAML(ISOUS)=MCHAML
  404.          IPCHA=MCHAML
  405.          MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
  406.          SEGACT MCHAM2
  407.          IPCHA2=MCHAM2
  408. C
  409.          CALL ADCHAM (IPCHA2,IPCHA,XX)
  410.          IF (IPCHA.EQ.0) THEN
  411.             SEGSUP MZONG,MZON1,MZON2
  412.             GOTO 9990
  413.          ENDIF
  414. C
  415.   540 CONTINUE
  416. C
  417.       SEGSUP MZONG,MZON1,MZON2
  418.       GOTO 666
  419. C
  420.  9990 CONTINUE
  421. C
  422. C     ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR
  423. C
  424.       SEGSUP MCHAML,MCHELM,ITAFF
  425.       IPCHAD=0
  426.       RETURN
  427. C
  428.   666 CONTINUE
  429.   777 CONTINUE
  430.  
  431.       END
  432.  
  433.  
  434.  

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