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    SP204843  24/10/25    21:15:03     12048          
  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.             SEGACT,MELVA1
  109.             SEGINI,MELVAL=MELVA1
  110.             N1PTEL=VELCHE(/1)
  111.             IF (N1PTEL.EQ.0) THEN
  112.                N2PTEL=IELCHE(/1)
  113.                N2EL  =IELCHE(/2)
  114.                IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  115.                   DO 122 IB=1,N2EL
  116.                      DO 121 IGAU=1,N2PTEL
  117.                         MLREE1=IELCHE(IGAU,IB)
  118.                         IF(MLREE1.EQ.0)THEN
  119.                            MLREEL=MLREE1
  120.                         ELSE
  121.                            SEGACT MLREE1
  122.                            JG=MLREE1.PROG(/1)
  123.                            SEGINI MLREEL
  124.                            DO 123 IPROG=1,JG
  125.                               PROG(IPROG)=XX*MLREE1.PROG(IPROG)
  126.  123                       CONTINUE
  127.                         ENDIF
  128.                         IELCHE(IGAU,IB)=MLREEL
  129.  121                 CONTINUE
  130.  122              CONTINUE
  131.                ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
  132.                   DO 126 IB=1,N2EL
  133.                      DO 125 IGAU=1,N2PTEL
  134.                         MEVOL1=IELCHE(IGAU,IB)
  135.                         CALL ADEVOL(MEVOL1,MEVOL1,MEVOL2,IEPS)
  136.                         IELCHE(IGAU,IB)=MEVOL2
  137.  125                 CONTINUE
  138.  126              CONTINUE
  139.                ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT   ') THEN
  140.                   SEGACT,MCOORD*mod
  141.                   NBNO=NBPTS
  142.                   NBNOI=NBNO
  143.                   NBPTS=NBNO+(N2PTEL*N2EL)
  144.                   SEGADJ,MCOORD
  145.                   DO 132 IB=1,N2EL
  146.                      DO 131 IGAU=1,N2PTEL
  147.                         IP=IELCHE(IGAU,IB)
  148.                         IF(IP.EQ.0)THEN
  149.                            NBPTS=IP
  150.                         ELSE
  151.                            IREF=(IP-1)*(IDIM+1)
  152.                            DO 133 IC=1,IDIM
  153.                            XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XX
  154.  133                       CONTINUE
  155.                      XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1))
  156.                         ENDIF
  157.                         IELCHE(IGAU,IB)=NBNOI+1
  158.                         NBNOI=NBNOI+1
  159.  131                 CONTINUE
  160.  132              CONTINUE
  161.                ELSE
  162. C
  163. C                 NOM DE COMPOSANTE NON RECONNU
  164. C
  165.                   MOTERR(1:4)=NOMCHE(ICOMP)
  166.                   CALL ERREUR(197)
  167.                   IPCHAD=0
  168.                   SEGSUP MELVAL,MCHAML,MCHELM
  169.                   RETURN
  170.                ENDIF
  171.             ELSE
  172.                N1EL=VELCHE(/2)
  173.                DO IB=1,N1EL
  174.                   DO IGAU=1,N1PTEL
  175.                      VELCHE(IGAU,IB)=XX*VELCHE(IGAU,IB)
  176.                   ENDDO
  177.                ENDDO
  178.             ENDIF
  179.             IELVAL(ICOMP) = MELVAL
  180.   111    CONTINUE
  181.   110 CONTINUE
  182.       GOTO 777
  183.  
  184. C_______________________________________________________________________
  185. C
  186. C      CAS GENERAL
  187. C_______________________________________________________________________
  188. C
  189.  1000 CONTINUE
  190.       MCHEL1=IPCHE1
  191.       MCHEL2=IPCHE2
  192.       SEGACT,MCHEL1,MCHEL2
  193. C
  194. C     ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
  195. C     DE SS TYPE DIFFERENTS
  196. C
  197.       IF (MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) THEN
  198.         MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8)
  199.         CALL ERREUR(99)
  200.         IPCHAD=0
  201.         GOTO 666
  202.       ENDIF
  203. C
  204.       MOT=MCHEL1.TITCHE
  205.       L1=MCHEL1.TITCHE(/1)
  206.       IF (MOT.EQ.'NOEUD'.OR.MOT.EQ.'GRAVITE' .OR.MOT.EQ.'RIGIDITE'.OR.
  207.      &    MOT.EQ.'MASSE'.OR.MOT.EQ.'STRESSES'.OR.MOT.EQ.'SCALAIRE') THEN
  208.          MOT= MCHEL2.TITCHE
  209.          L1 = MCHEL2.TITCHE(/1)
  210.       ENDIF
  211.       N3    =MCHEL1.INFCHE(/2)
  212. C* On doit avoir N3=6
  213.       NSOUS1=MCHEL1.ICHAML(/1)
  214.       NSOUS2=MCHEL2.ICHAML(/1)
  215. C
  216. C QUELLE BIJECTION ENTRE LES SOUS PAQUETS  SI OUI TRAITEMENT AMELIORE
  217. C
  218.       IF (NSOUS1.NE.NSOUS2) GOTO 4000
  219. C
  220.       SEGINI ITAFF
  221.       DO 17 ISOUS1=1,NSOUS1
  222.          IPMAI1 = MCHEL1.IMACHE(ISOUS1)
  223.          CONCH1 = MCHEL1.CONCHE(ISOUS1)
  224.          DO 18 ISOUS2=1,NSOUS2
  225.             ISOUS=ISOUS2
  226.             IPMAI2= MCHEL2.IMACHE(ISOUS)
  227.             CONCH2= MCHEL2.CONCHE(ISOUS)
  228.             IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN
  229. C
  230. C              VERIFICATION POUR LES INFCHE
  231. C
  232.                CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  233.                IF (IRTD.EQ.0) GOTO 18
  234.                IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  235.                IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  236.                IF (IMINT1.EQ.IMINT2) GOTO 171
  237.                IMINT1 = MCHEL1.INFCHE(ISOUS1,6)
  238. c*               IF (IMINT1.EQ.0) IMINT1 = 1
  239.                IMINT2 = MCHEL2.INFCHE(ISOUS2,6)
  240. c*               IF (IMINT2.EQ.0) IMINT2 = 1
  241.                IF (IMINT1.EQ.IMINT2) GOTO 171
  242. C
  243. C              ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
  244. C              DE SS TYPE DIFFERENTS
  245. C
  246.                MOTERR(1:8)=MCHEL1.TITCHE
  247.                MOTERR(9:16)=MCHEL2.TITCHE
  248.                CALL ERREUR(329)
  249.                SEGSUP ITAFF
  250.                IPCHAD=0
  251.                RETURN
  252.             ENDIF
  253.   18     CONTINUE
  254.          SEGSUP ITAFF
  255.          GOTO 4000
  256.  
  257.   171    CONTINUE
  258. C        Ici, les zones ISOUS1 et ISOUS2 ont meme maillage,
  259. c        meme constituant, meme segment d'integration
  260.          JTAFF(**)=MCHEL2.ICHAML(ISOUS)
  261.  
  262.   17  CONTINUE
  263. C
  264. C     ON A TROUVE UNE BIJECTION ET ON VECTORISE
  265. C
  266.       N1=NSOUS1
  267. C*      N3 = 6
  268.       SEGINI MCHELM
  269.       TITCHE=MOT
  270.       IFOCHE=IFOUR
  271.       IPCHAD=MCHELM
  272.       DO 400 ISOUS=1,NSOUS1
  273.          IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
  274.          CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  275.          DO 401 N33=1,N3
  276.             INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33)
  277.  401     CONTINUE
  278. C
  279.          MCHAM1=MCHEL1.ICHAML(ISOUS)
  280. C
  281.          SEGINI,MCHAML=MCHAM1
  282.          ICHAML(ISOUS)=MCHAML
  283.          IPCHA=MCHAML
  284. C
  285.          MCHAM2=JTAFF(ISOUS)
  286.          SEGACT MCHAM2
  287.          IPCHA2=MCHAM2
  288. C
  289.          CALL ADCHAM (IPCHA2,IPCHA,XX)
  290.          IF (IPCHA.EQ.0) THEN
  291.             SEGSUP ITAFF
  292.             GOTO 9990
  293.          ENDIF
  294. C
  295.   400 CONTINUE
  296.       SEGSUP ITAFF
  297.       GOTO 666
  298. C_______________________________________________________________________
  299. C
  300. C     ON A PAS TROUVE DE BIJECTION
  301. C_______________________________________________________________________
  302. C
  303.  4000 CONTINUE
  304.       SEGINI MZONG,MZON1,MZON2
  305.       DO 500 ISOUS1=1,NSOUS1
  306.          NZONG(**)=MCHEL1.IMACHE(ISOUS1)
  307.          NZON1(**)=ISOUS1
  308.          NZON2(**)=0
  309.   500 CONTINUE
  310.       IWRN=0
  311.       DO 510 ISOUS2=1,NSOUS2
  312.          IPMAI2 = MCHEL2.IMACHE(ISOUS2)
  313.          CONCH2 = MCHEL2.CONCHE(ISOUS2)
  314.          DO 520 ISOUS1=1,NSOUS1
  315.             IPMAI1= MCHEL1.IMACHE(ISOUS1)
  316.             CONCH1= MCHEL1.CONCHE(ISOUS1)
  317.             IF (IPMAI1.EQ.IPMAI2 .AND.CONCH1.EQ.CONCH2) THEN
  318.                CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  319.                IF (IRTD.EQ.0) GOTO 520
  320. C
  321. C              VERIFICATION POUR LES MINTES
  322. C
  323.                IF ( MCHEL1.INFCHE(ISOUS1,6).EQ.
  324.      &              MCHEL2.INFCHE(ISOUS2,6) ) GOTO 530
  325. C
  326. C              ERREUR SUR LES SUPPORTS DES MCHAML
  327. C
  328.                MOTERR(1:8) =MCHEL1.TITCHE
  329.                MOTERR(9:16)=MCHEL2.TITCHE
  330.                CALL ERREUR(329)
  331.                IPCHAD=0
  332.                SEGSUP MZONG,MZON1,MZON2
  333.                RETURN
  334.             ENDIF
  335.   520    CONTINUE
  336.          IWRN=1
  337.          NZONG(**)=IPMAI2
  338.          NZON1(**)=0
  339.          NZON2(**)=ISOUS2
  340.          GOTO 510
  341. C
  342.   530    CONTINUE
  343.          if (nzon2(isous1).ne.0) call erreur(329)
  344.          NZON2(ISOUS1)=ISOUS2
  345.   510 CONTINUE
  346. C
  347. C   WARNING  LES SOUS ZONES GEOMETRIQUES NE SE CORRESPONDENT PAS 2 A 2
  348. C
  349.       NSOUS=NZONG(/1)
  350.       N1=NSOUS
  351. C*      N3=6
  352.       SEGINI MCHELM
  353.       TITCHE=MOT
  354.       IFOCHE=IFOUR
  355.       IPCHAD=MCHELM
  356. C
  357.       DO 540 ISOUS=1,NSOUS
  358.          BOOLSO=.FALSE.
  359.          IF(NZON1(ISOUS).NE.0.AND.NZON2(ISOUS).NE.0) GOTO 550
  360. C
  361.          IF(NZON1(ISOUS).NE.0) THEN
  362.             MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) )
  363.             SEGINI,MCHAML=MCHAM1
  364.             IMACHE(ISOUS)=NZONG(ISOUS)
  365.             CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) )
  366.             DO 402 N33=1,N3
  367.                INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33)
  368.  402        CONTINUE
  369.          ENDIF
  370.          IF(NZON2(ISOUS).NE.0) THEN
  371.             IF(IEPS .EQ. -1) BOOLSO=.TRUE.
  372.             MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
  373.             SEGINI,MCHAML=MCHAM2
  374.             IMACHE(ISOUS)=NZONG(ISOUS)
  375.             CONCHE(ISOUS)=MCHEL2.CONCHE( NZON2(ISOUS) )
  376.             DO 403 N33=1,N3
  377.                INFCHE(ISOUS,N33)=MCHEL2.INFCHE(NZON2(ISOUS),N33)
  378.  403        CONTINUE
  379.          ENDIF
  380.          ICHAML(ISOUS)=MCHAML
  381. C
  382.          DO 175 ICOMP=1,IELVAL(/1)
  383.             MELVA1=IELVAL(ICOMP)
  384.             SEGACT,MELVA1
  385.             SEGINI,MELVAL=MELVA1
  386.             IELVAL(ICOMP)=MELVAL
  387. C CB215821  Si c'est la soustraction qu'on demande il faut faire * XX...
  388. C           sur les SOUS-ZONES issues du 2ème MCHAML (BOOLSO = .TRUE.)
  389.             IF (BOOLSO) THEN
  390.                 TYPCH2=TYPCHE(ICOMP)
  391.                 CALL MULMEL(MELVAL,XX,TYPCH2)
  392.             ENDIF
  393.  175     CONTINUE
  394. C
  395.          GOTO 540
  396. C
  397.   550    CONTINUE
  398.          MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) )
  399.          SEGINI,MCHAML=MCHAM1
  400.          IMACHE(ISOUS)=NZONG(ISOUS)
  401.          CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) )
  402.          DO 404 N33=1,N3
  403.             INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33)
  404.  404     CONTINUE
  405.          ICHAML(ISOUS)=MCHAML
  406.          IPCHA=MCHAML
  407.          MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
  408.          SEGACT MCHAM2
  409.          IPCHA2=MCHAM2
  410. C
  411.          CALL ADCHAM (IPCHA2,IPCHA,XX)
  412.          IF (IPCHA.EQ.0) THEN
  413.             SEGSUP MZONG,MZON1,MZON2
  414.             GOTO 9990
  415.          ENDIF
  416. C
  417.   540 CONTINUE
  418. C
  419.       SEGSUP MZONG,MZON1,MZON2
  420.       GOTO 666
  421. C
  422.  9990 CONTINUE
  423. C
  424. C     ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR
  425. C
  426.       SEGSUP MCHAML,MCHELM,ITAFF
  427.       IPCHAD=0
  428.       RETURN
  429. C
  430.   666 CONTINUE
  431.   777 CONTINUE
  432.  
  433.       END
  434.  
  435.  
  436.  
  437.  

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