Télécharger la plaquette Cast3M


fr en

Télécharger chapo.eso

Retour à la liste

Numérotation des lignes : 

chapo

  1. C CHAPO     SOURCE    MB234859  25/09/08    21:15:10     12358          
  2. C
  3.       SUBROUTINE CHAPO(IPMODL,IPCHAM,IPCARA,IPCHPO,IRET)
  4. C=======================================================================
  5. C
  6. C     TRANSFORME LE MCHAML IPCHAM EN CHPOINT IPCHPO
  7. C     il y a deja eu un reduaf sur IPMODL du mchaml -> IPCHAM
  8. C
  9. C=======================================================================
  10.       IMPLICIT INTEGER(I-N)
  11.       IMPLICIT REAL*8(A-H,O-Z)
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15.  
  16. -INC SMMODEL
  17. -INC SMCHAML
  18. c -INC SMCHPOI
  19. -INC SMELEME
  20. -INC SMCOORD
  21. -INC SMINTE
  22.  
  23. -INC TMPTVAL
  24. -INC TMTRAV
  25.  
  26.       SEGMENT NOTYPE
  27.         CHARACTER*16 TYPE(NBTYPE)
  28.       ENDSEGMENT
  29.  
  30. c   tableau inverse pour retrouver la position d'inconnue
  31.       SEGMENT KINCO(NINCO)
  32.  
  33.       SEGMENT MWRK1
  34.         REAL*8 XEL(3,NBN1)
  35.       ENDSEGMENT
  36.  
  37.       SEGMENT MWRK2
  38.         REAL*8 TXR(3,3,NBN1),TH(NBN1)
  39.       ENDSEGMENT
  40.  
  41.       PARAMETER (LTIT=72)
  42.       CHARACTER*(LTIT) TITCH1
  43.       DIMENSION XIGAU(3)
  44.       DIMENSION INFOS(3)
  45.       CHARACTER*(NCONCH) CONM
  46.  
  47. ************************************************************************
  48. *     PRELIMINAIRES
  49. ************************************************************************
  50.       IRET=1
  51.  
  52.       IDIMP1 = IDIM + 1
  53.       SEGACT MCOORD*MOD
  54.  
  55. *  ACTIVATION DU MMODEL et MCHAML
  56.  
  57.       MMODEL=IPMODL
  58.       NSOUS=KMODEL(/1)
  59.  
  60.       MCHELM=IPCHAM
  61.       NSC  = mchelm.INFCHE(/1)
  62.       IF (NSC .EQ. 0) THEN
  63.          write(IOIMP,*) 'CHAPO : MCHAML VIDE'
  64.          call erreur(21)
  65. c         retourner un CHPOINT vide
  66.          RETURN
  67.       ENDIF
  68.  
  69. *  Verification du support : noeuds ou points d'integration (Gauss) ?
  70.       ISUP = INFCHE(1,6)
  71.       DO ISC = 2, NSC
  72.          ISUP1 = INFCHE(ISC,6)
  73.          IF (ISUP1.NE.ISUP) ISUP = 0
  74.       ENDDO
  75. *   si ISUP = 1 : MCHAML aux noeuds
  76. *   si ISUP = 2 : MCHAML au centre de gravite
  77. *   si ISUP = 3 : MCHAML aux point d integration (rigidite)
  78. *   si ISUP = 4 : MCHAML aux point d integration (masse)
  79. *   si ISUP = 5 : MCHAML aux point d integration (stresses)
  80. *   si ISUP = 6 : MCHAML aux point d integration de T
  81.       IF (ISUP.LE.1.OR.ISUP.GT.6) THEN
  82.          write(IOIMP,*) 'Supports incoherents',(INFCHE(isc,6),isc=1,NSC)
  83.          call erreur(609)
  84.          RETURN
  85.       ENDIF
  86.  
  87. c   On recupere TITCH1 dimensionne a 72 comme MOCHDE du SMCHPOI
  88.       LTIT1 = min(LTIT,TITCHE(/1))
  89.       TITCH1(1:LTIT1) = TITCHE(1:LTIT1)
  90.  
  91. c   Segment MTRAV et ses dimensions
  92.       NNIN =0
  93.       NNNOE=0
  94.       MTRAV=0
  95.  
  96.       nbtype = 1
  97.       SEGINI,notype
  98.       notype.TYPE(1) = 'REAL*8'
  99.       MOTYR8 = notype
  100.  
  101. ************************************************************************
  102. *     Boucle sur les zones du MCHAML
  103. ************************************************************************
  104.       isous = 0
  105.       DO 100 ISOU = 1,NSOUS
  106.  
  107.          MELVEP  = 0
  108.  
  109.          IMODEL = KMODEL(ISOU)
  110.          IPMAIL = IMAMOD
  111.          CONM   = CONMOD
  112.          MELE   = NEFMOD
  113.  
  114.          MELEME = IPMAIL
  115. c          write(6,*) '==== zone',ISOU,'/',NSOUS,' itypel =',itypel
  116.          IF (itypel.eq.48) goto 100
  117.          isous = isous+1
  118. c          write(6,*) '  => zone ok : ISOUS=', ISOUS
  119.  
  120. *        RECUP DU SEGMENT D'INTEGRATION MINTE
  121.          if (infmod(/1).lt.7) then
  122.            write(ioimp,*) 'chapo : infmod(/1) < 7'
  123.            call erreur(5)
  124.          endif
  125.  
  126. c*       NBGS   = INFELE(4)
  127.          MFR    = INFELE(13)
  128.          MINTE  = INFMOD(ISUP+2)
  129.          MINTE1 = INFMOD(3)
  130.  
  131. c*Active par ACTOBJ :         SEGACT,minte
  132. c*Active par ACTOBJ :         IF (ISUP.GE.5.AND.MFR.EQ.5) SEGACT,minte1
  133.  
  134.          CALL IDENT(IPMAIL,CONM,IPCHAM,0,INFOS,IRET)
  135. c         IF (IRET.EQ.0) call erreur(5)
  136.  
  137.          NBN1   = meleme.NUM(/1)
  138.          NBELE1 = meleme.NUM(/2)
  139.  
  140.          IF (ISUP.EQ.1) THEN
  141.            NIPO = NBN1
  142.          ELSE
  143.            NBPGAU = minte.POIGAU(/1)
  144.            NIPO = NBPGAU
  145.          ENDIF
  146.  
  147.          IF (MFR.EQ.5) THEN
  148.            IF (IPCARA.EQ.0) THEN
  149.              MOTERR(1:16) = 'CARACTERISTIQUES'
  150.              CALL ERREUR(565)
  151.              write(ioimp,*) 'erreur manque IPCARA'
  152.              RETURN
  153.            ENDIF
  154. *        Cas des coques epaisses : recup de l'epaisseur
  155. *        on neglige l'excentrement
  156.             IF (ISUP.GE.5) THEN
  157.                NBROBL = 1
  158.                NBRFAC = 0
  159.                SEGINI,nomid
  160.                LESOBL(1) = 'EPAI'
  161.                MOEP = nomid
  162.                CALL KOMCHA(IPCARA,IPMAIL,CONM,MOEP,
  163.      &                     MOTYR8,1,INFOS,3,IVAEP)
  164.                SEGSUP,nomid
  165.                IF (IERR.NE.0) RETURN
  166.                mptval = IVAEP
  167.                MELVEP = IVAL(1)
  168.                SEGSUP,mptval
  169.             ENDIF
  170.           ENDIF
  171.  
  172. *        creation des segments de travail
  173.          SEGINI MWRK1
  174.          NPPO = NIPO * NBELE1
  175. c          write(6,*) 'nb pts support', NIPO, '* nb elem',NBELE1,'=',NPPO
  176.          IF (ISUP.GE.5.AND.MFR.EQ.5) SEGINI MWRK2
  177.  
  178. *        ACTIVATION DU SOUS-MCHELM MCHAML
  179.          MCHAML = ICHAML(ISOUS)
  180.          NC     = IELVAL(/1)
  181.  
  182. *        CREATION/AJUSTEMENT DU MTRAV
  183. *        + REMPLISSAGE DE INCO et de KINCO
  184.          NINCO=NC
  185.          SEGINI,KINCO
  186. c       -1er passage :
  187.          IF(ISOUS.EQ.1) THEN
  188.            NNIN =NC
  189.            NNNOE1=0
  190.            NNNOE=NPPO
  191.            SEGINI,MTRAV
  192. c          toutes les composantes sont nouvelles
  193.            DO IC=1,NC
  194.              INCO(IC) = NOMCHE(IC)
  195.              NHAR(IC) = INFCHE(ISOU,3)
  196.              KINCO(IC)= IC
  197.            ENDDO
  198. c       -passages suivants :
  199.          ELSE
  200. c          on dimensionne au plus large
  201.            NNIN1=NNIN
  202.            NNIN =NNIN+NC
  203.            NNNOE1=NNNOE
  204.            NNNOE=NNNOE+NPPO
  205.            SEGADJ,MTRAV
  206. c          recherche des composantes nouvelles
  207. C          pour MCHAML
  208.            NCNEW=0
  209.            DO 101 IC=1,NC
  210.              DO 102 IIN=1,NNIN1
  211.                IF(INCO(IIN).NE.NOMCHE(IC)) GOTO 102
  212.                IF(NHAR(IIN).EQ.INFCHE(ISOU,3)) THEN
  213.                  KINCO(IC)=IIN
  214.                  GOTO 101
  215.                ENDIF
  216.  102         CONTINUE
  217. c            nouvelle composante !
  218.              NCNEW=NCNEW+1
  219.              INCO(NCNEW)=NOMCHE(IC)
  220.              NHAR(NCNEW)=INFCHE(ISOU,3)
  221.              KINCO(IC)=NCNEW
  222.  101       CONTINUE
  223. c          on remet a la bonne taille
  224.            NNIN=NNIN1+NCNEW
  225.            SEGADJ,MTRAV
  226.          ENDIF
  227.  
  228. *        + REMPLISSAGE DE IGEO et de IBIN
  229. c        sympa: a priori, tous les noeuds sont nouveaux !
  230.          NBPTS1 = NBPTS
  231.          DO INOE = NNNOE1 + 1,NNNOE
  232.            NBPTS = NBPTS + 1
  233.            IGEO(INOE)=NBPTS
  234.            do IC=1,NC
  235.               IIN            = KINCO(IC)
  236.               IBIN(IIN,INOE) = 1
  237.            enddo
  238.          ENDDO
  239.          SEGADJ,MCOORD
  240. c          WRITE(*,*) 'INCO=',(INCO(iou),iou=1,NNIN)
  241. c        IN NE RESTE QU'A REMPLIR BB...
  242.  
  243. *=======================================================================
  244. *        Boucle sur les composantes
  245.          DO 150 IC = 1,NC
  246.  
  247. c             write(6,*) '============ ISOU,IC=',ISOU,IC,'IMODEL=',IMODEL
  248. *           Recup du melval
  249.             MELVAL=IELVAL(IC)
  250. **
  251. *           recup de la position IIN dans MTRAV
  252.             DO 151 IIN=1,NNIN
  253.                IF(INCO(IIN).EQ.NOMCHE(IC)) GOTO 152
  254.  151        CONTINUE
  255.             CALL ERREUR(5)
  256.             RETURN
  257.  152        CONTINUE
  258. *           + debut des nouveaux noeuds
  259.             INOE = NNNOE1
  260.  
  261. *---------- Boucle sur les elements ------------------------------
  262.  
  263.             DO 200 IEL = 1,NBELE1
  264.  
  265. *              cas general
  266.                CALL DOXE(XCOOR,IDIM,NBN1,NUM,IEL,XEL)
  267.  
  268. *              coques epaisses
  269.                IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  270.                   MELVA1=MELVEP
  271.                   DO 201 IP = 1,NBN1
  272.                      IPMN=MIN(IP ,MELVA1.VELCHE(/1))
  273.                      IEMN=MIN(IEL,MELVA1.VELCHE(/2))
  274.                      TH(IP)=MELVA1.VELCHE(IPMN,IEMN)
  275.  201              CONTINUE
  276.                   CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR)
  277.                ENDIF
  278.  
  279. *............. Boucle sur les points supports .............
  280.  
  281.                DO 300 IPSU = 1,NIPO
  282.  
  283. *               remplissage des valeurs CHAMELEM -> MTRAV
  284.                   IPMN = MIN(IPSU,VELCHE(/1))
  285.                   IEMN = MIN(IEL ,VELCHE(/2))
  286.                   INOE=INOE+1
  287.                   BB(IIN,INOE) = VELCHE(IPMN,IEMN)
  288.  
  289. *               1er passage : on calcule les coord du pt d integration
  290.                   IF (IC.EQ.1) THEN
  291.                      IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  292.                         Z = 0.5D0 * DZEGAU(IPSU)
  293.                         DO I2 = 1, IDIM
  294.                            r_z = 0.D0
  295.                            DO IL = 1,NBN1
  296.                               r_z = r_z + (SHPTOT(1,IL,IPSU)*
  297.      &                        XEL(I2,IL)+ Z*TXR(I2,3,IL)*TH(IL))
  298.                            ENDDO
  299.                            XIGAU(I2) = r_z
  300.                         ENDDO
  301.                      ELSE
  302.                         DO I2 = 1, IDIM
  303.                            r_z = 0.D0
  304.                            DO IL = 1, NBN1
  305.                               r_z = r_z + SHPTOT(1,IL,IPSU)*XEL(I2,IL)
  306.                            ENDDO
  307.                            XIGAU(I2) = r_z
  308.                         ENDDO
  309.                      ENDIF
  310. *                 Le pdi est cree dans MCOORD
  311.                      KPTS=(IGEO(INOE)-1)*IDIMP1
  312.                      XCOOR(KPTS+1) = XIGAU(1)
  313.                      XCOOR(KPTS+2) = XIGAU(2)
  314.                      IF (IDIM.EQ.3) XCOOR(KPTS+3)=XIGAU(3)
  315.                      XCOOR(KPTS+IDIMP1) = 0.D0
  316.                   ENDIF
  317.  
  318.  300           CONTINUE
  319. *............. fin de Boucle sur les points supports ..........
  320.  
  321.  200        CONTINUE
  322. *---------- Fin de Boucle sur les elements -----------------------
  323.  
  324.  150     CONTINUE
  325.  
  326. *        Fin de Boucle sur les composantes
  327. *=======================================================================
  328.  
  329. *      Desactivation des segments de la zone ISOU
  330.          SEGSUP,MWRK1
  331.          IF (ISUP.GE.5.AND.MFR.EQ.5) SEGSUP MWRK2
  332.          SEGSUP,KINCO
  333.  
  334.  100  CONTINUE
  335. ************************************************************************
  336. *     FIN DE Boucle sur les zones du MCHAML
  337. ************************************************************************
  338.  
  339. ************************************************************************
  340. *     CREATION DU CHPOINT FINAL A PARTIR DU MTRAV
  341. ************************************************************************
  342.       CALL CRECHP (MTRAV,IPCHP1)
  343.       SEGSUP,MTRAV
  344.       IPCHPO=IPCHP1
  345.  
  346.  900  CONTINUE
  347.       notype = MOTYR8
  348.       SEGSUP,notype
  349.  
  350.       SEGDES,MCOORD
  351.  
  352. C      RETURN
  353.       END
  354.  
  355.  
  356.  
  357.  

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