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

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